From 2b1afd2abaaf893c93ea93cb5d7d68980f063fce Mon Sep 17 00:00:00 2001 From: Sven Luther Date: Mon, 12 Jul 2004 12:42:57 +0000 Subject: [PATCH] Imported Upstream version 3.07.99 --- .depend | 52 +- Changes | 106 +- INSTALL | 25 +- INSTALL.MPW | 89 - Makefile | 8 +- Makefile.Mac | 488 -- Makefile.Mac.depend | 548 -- README | 7 +- README.win32 | 10 +- Upgrading | 4 +- asmcomp/alpha/emit.mlp | 18 +- asmcomp/amd64/emit.mlp | 58 +- asmcomp/arm/emit.mlp | 25 +- asmcomp/asmlink.ml | 22 +- asmcomp/asmpackager.ml | 173 +- asmcomp/clambda.ml | 4 +- asmcomp/clambda.mli | 4 +- asmcomp/closure.ml | 17 +- asmcomp/cmmgen.ml | 321 +- asmcomp/cmmgen.mli | 3 +- asmcomp/compilenv.ml | 15 +- asmcomp/compilenv.mli | 15 +- asmcomp/hppa/emit.mlp | 227 +- asmcomp/hppa/proc.ml | 4 +- asmcomp/i386/emit.mlp | 34 +- asmcomp/i386/emit_nt.mlp | 42 +- asmcomp/ia64/emit.mlp | 36 +- asmcomp/ia64/selection.ml | 4 +- asmcomp/interf.ml | 66 +- asmcomp/mips/emit.mlp | 14 +- asmcomp/power/arch.ml | 21 +- asmcomp/power/emit.mlp | 305 +- asmcomp/power/proc.ml | 14 +- asmcomp/power/scheduling.ml | 6 +- asmcomp/power/selection.ml | 8 +- asmcomp/sparc/emit.mlp | 14 +- asmrun/.depend | 36 +- asmrun/Makefile | 12 +- asmrun/alpha.S | 88 +- asmrun/amd64.S | 61 +- asmrun/arm.S | 66 +- asmrun/fail.c | 131 +- asmrun/hppa.S | 138 +- asmrun/i386.S | 70 +- asmrun/i386nt.asm | 73 +- asmrun/ia64.S | 90 +- asmrun/m68k.S | 62 +- asmrun/mips.s | 86 +- asmrun/power-aix.S | 88 +- asmrun/power-elf.S | 58 +- asmrun/power-rhapsody.S | 56 +- asmrun/roots.c | 38 +- asmrun/signals.c | 260 +- asmrun/sparc.S | 104 +- asmrun/stack.h | 8 +- asmrun/startup.c | 43 +- boot/ocamlc | Bin 920677 -> 967128 bytes boot/ocamllex | Bin 147415 -> 152480 bytes bytecomp/bytegen.ml | 121 +- bytecomp/bytelink.ml | 68 +- bytecomp/bytepackager.ml | 103 +- bytecomp/bytesections.ml | 10 +- bytecomp/bytesections.mli | 7 +- bytecomp/dll.ml | 14 +- bytecomp/emitcode.ml | 4 +- bytecomp/instruct.ml | 4 +- bytecomp/instruct.mli | 4 +- bytecomp/lambda.ml | 69 +- bytecomp/lambda.mli | 7 +- bytecomp/matching.ml | 24 +- bytecomp/matching.mli | 6 +- bytecomp/meta.ml | 19 +- bytecomp/meta.mli | 19 +- bytecomp/printinstr.ml | 4 +- bytecomp/printlambda.ml | 8 +- bytecomp/simplif.ml | 14 +- bytecomp/symtable.ml | 84 +- bytecomp/symtable.mli | 4 +- bytecomp/translclass.ml | 724 +- bytecomp/translclass.mli | 5 +- bytecomp/translcore.ml | 174 +- bytecomp/translcore.mli | 4 +- bytecomp/translmod.ml | 55 +- bytecomp/translmod.mli | 7 +- bytecomp/translobj.ml | 138 +- bytecomp/translobj.mli | 16 +- bytecomp/typeopt.ml | 5 +- byterun/.depend | 499 +- byterun/Makefile | 13 +- byterun/Makefile.Mac | 118 - byterun/Makefile.Mac.depend | 1180 ---- byterun/Makefile.nt | 8 +- byterun/alloc.c | 53 +- byterun/alloc.h | 45 +- byterun/array.c | 74 +- byterun/backtrace.c | 78 +- byterun/backtrace.h | 35 +- byterun/callback.c | 107 +- byterun/callback.h | 32 +- byterun/compact.c | 107 +- byterun/compact.h | 12 +- byterun/compare.c | 116 +- byterun/{macintosh.h => compare.h} | 14 +- byterun/compatibility.h | 309 + byterun/config.h | 19 +- byterun/custom.c | 42 +- byterun/custom.h | 28 +- byterun/debugger.c | 162 +- byterun/debugger.h | 20 +- byterun/dynlink.c | 124 +- byterun/dynlink.h | 18 +- byterun/exec.h | 10 +- byterun/extern.c | 183 +- byterun/fail.c | 93 +- byterun/fail.h | 50 +- byterun/finalise.c | 165 +- byterun/finalise.h | 21 +- byterun/fix_code.c | 64 +- byterun/fix_code.h | 30 +- byterun/floats.c | 207 +- byterun/freelist.c | 82 +- byterun/freelist.h | 22 +- byterun/gc.h | 8 +- byterun/gc_ctrl.c | 266 +- byterun/gc_ctrl.h | 32 +- byterun/globroots.c | 12 +- byterun/globroots.h | 8 +- byterun/hash.c | 11 +- byterun/instrtrace.c | 216 +- byterun/instrtrace.h | 14 +- byterun/instruct.h | 8 +- byterun/int64_emul.h | 15 +- byterun/int64_format.h | 7 +- byterun/int64_native.h | 8 +- byterun/intern.c | 199 +- byterun/interp.c | 241 +- byterun/interp.h | 17 +- byterun/intext.h | 96 +- byterun/ints.c | 403 +- byterun/io.c | 266 +- byterun/io.h | 60 +- byterun/lexing.c | 14 +- byterun/macintosh.c | 319 - byterun/main.c | 16 +- byterun/major_gc.c | 264 +- byterun/major_gc.h | 41 +- byterun/md5.c | 56 +- byterun/md5.h | 22 +- byterun/memory.c | 262 +- byterun/memory.h | 166 +- byterun/meta.c | 99 +- byterun/minor_gc.c | 161 +- byterun/minor_gc.h | 35 +- byterun/misc.c | 56 +- byterun/misc.h | 50 +- byterun/mlvalues.h | 42 +- byterun/mpwtool.c | 39 - byterun/obj.c | 145 +- byterun/osdeps.h | 19 +- byterun/parsing.c | 35 +- byterun/prims.h | 21 +- byterun/printexc.c | 35 +- byterun/printexc.h | 12 +- byterun/reverse.h | 8 +- byterun/roots.c | 48 +- byterun/roots.h | 26 +- byterun/rotatecursor.c | 120 - byterun/rotatecursor.h | 124 - byterun/signals.c | 134 +- byterun/signals.h | 42 +- byterun/stacks.c | 95 +- byterun/stacks.h | 28 +- byterun/startup.c | 196 +- byterun/startup.h | 43 +- byterun/str.c | 61 +- byterun/sys.c | 162 +- byterun/sys.h | 14 +- byterun/terminfo.c | 26 +- byterun/ui.h | 7 +- byterun/unix.c | 56 +- byterun/weak.c | 66 +- byterun/weak.h | 10 +- byterun/win32.c | 66 +- camlp4/CHANGES | 20 + camlp4/ICHANGES | 10 + camlp4/Makefile | 29 +- camlp4/Makefile.Mac | 204 - camlp4/camlp4/.depend | 10 +- camlp4/camlp4/Makefile | 37 +- camlp4/camlp4/Makefile.Mac | 69 - camlp4/camlp4/Makefile.Mac.depend | 15 - camlp4/camlp4/argl.ml | 17 +- camlp4/camlp4/ast2pt.ml | 85 +- camlp4/camlp4/ast2pt.mli | 6 +- camlp4/camlp4/mLast.mli | 5 +- camlp4/camlp4/pcaml.ml | 61 +- camlp4/camlp4/pcaml.mli | 32 +- camlp4/camlp4/reloc.ml | 357 +- camlp4/camlp4/reloc.mli | 23 +- camlp4/compile/.depend | 2 + camlp4/compile/Makefile | 5 +- camlp4/compile/comp_trail.ml | 2 +- camlp4/compile/compile.ml | 18 +- camlp4/config/Makefile.tpl | 30 +- camlp4/etc/.depend | 28 - camlp4/etc/Makefile | 52 +- camlp4/etc/Makefile.Mac | 71 - camlp4/etc/Makefile.Mac.depend | 40 - camlp4/etc/pa_ifdef.ml | 8 +- camlp4/etc/pa_lisp.ml | 684 -- camlp4/etc/pa_lispr.ml | 665 -- camlp4/etc/pa_o.ml | 26 +- camlp4/etc/pa_oop.ml | 3 +- camlp4/etc/parserify.ml | 4 +- camlp4/etc/pr_extend.ml | 12 +- camlp4/etc/pr_extfun.ml | 4 +- camlp4/etc/pr_o.ml | 66 +- camlp4/etc/pr_op_main.ml | 4 +- camlp4/etc/pr_r.ml | 56 +- camlp4/etc/pr_rp.ml | 4 +- camlp4/etc/pr_rp_main.ml | 4 +- camlp4/etc/q_phony.ml | 6 +- camlp4/lib/.depend | 5 +- camlp4/lib/Makefile | 20 +- camlp4/lib/Makefile.Mac | 46 - camlp4/lib/Makefile.Mac.depend | 13 - camlp4/lib/grammar.ml | 15 +- camlp4/lib/grammar.mli | 4 +- camlp4/lib/plexer.ml | 530 +- camlp4/lib/stdpp.ml | 13 +- camlp4/lib/stdpp.mli | 8 +- camlp4/lib/token.ml | 120 +- camlp4/lib/token.mli | 39 +- camlp4/man/Makefile.Mac | 31 - camlp4/meta/.depend | 12 +- camlp4/meta/Makefile | 10 +- camlp4/meta/Makefile.Mac | 50 - camlp4/meta/Makefile.Mac.depend | 12 - camlp4/meta/mk_q_MLast.sh | 12 - camlp4/meta/pa_extend.ml | 31 +- camlp4/meta/pa_ifdef.ml | 85 - camlp4/meta/pa_macro.ml | 170 +- camlp4/meta/pa_r.ml | 36 +- camlp4/meta/q_MLast.ml | 51 +- camlp4/ocaml_src/camlp4/.depend | 10 +- camlp4/ocaml_src/camlp4/Makefile | 35 +- camlp4/ocaml_src/camlp4/Makefile.Mac | 69 - camlp4/ocaml_src/camlp4/Makefile.Mac.depend | 15 - camlp4/ocaml_src/camlp4/argl.ml | 30 +- camlp4/ocaml_src/camlp4/ast2pt.ml | 60 +- camlp4/ocaml_src/camlp4/ast2pt.mli | 4 +- camlp4/ocaml_src/camlp4/mLast.mli | 3 +- camlp4/ocaml_src/camlp4/pcaml.ml | 101 +- camlp4/ocaml_src/camlp4/pcaml.mli | 48 +- camlp4/ocaml_src/camlp4/reloc.ml | 416 +- camlp4/ocaml_src/camlp4/reloc.mli | 37 +- camlp4/ocaml_src/lib/.depend | 5 +- camlp4/ocaml_src/lib/Makefile | 18 +- camlp4/ocaml_src/lib/Makefile.Mac | 46 - camlp4/ocaml_src/lib/Makefile.Mac.depend | 13 - camlp4/ocaml_src/lib/grammar.ml | 12 +- camlp4/ocaml_src/lib/grammar.mli | 2 +- camlp4/ocaml_src/lib/plexer.ml | 613 +- camlp4/ocaml_src/lib/stdpp.ml | 104 +- camlp4/ocaml_src/lib/stdpp.mli | 6 +- camlp4/ocaml_src/lib/token.ml | 90 +- camlp4/ocaml_src/lib/token.mli | 37 +- camlp4/ocaml_src/meta/.depend | 12 +- camlp4/ocaml_src/meta/Makefile | 8 +- camlp4/ocaml_src/meta/Makefile.Mac | 50 - camlp4/ocaml_src/meta/Makefile.Mac.depend | 12 - camlp4/ocaml_src/meta/pa_extend.ml | 227 +- camlp4/ocaml_src/meta/pa_extend_m.ml | 17 +- camlp4/ocaml_src/meta/pa_ifdef.ml | 216 - camlp4/ocaml_src/meta/pa_macro.ml | 274 +- camlp4/ocaml_src/meta/pa_r.ml | 1107 ++-- camlp4/ocaml_src/meta/pa_rp.ml | 46 +- camlp4/ocaml_src/meta/q_MLast.ml | 1876 ++++-- camlp4/ocaml_src/odyl/.depend | 6 +- camlp4/ocaml_src/odyl/Makefile | 24 +- camlp4/ocaml_src/odyl/Makefile.Mac | 49 - camlp4/ocaml_src/odyl/Makefile.Mac.depend | 4 - camlp4/ocaml_src/odyl/odyl.ml | 4 + camlp4/ocaml_src/odyl/odyl_main.ml | 3 +- camlp4/ocpp/Makefile | 4 +- camlp4/ocpp/Makefile.Mac | 41 - camlp4/ocpp/ocpp.ml | 17 +- camlp4/odyl/.depend | 6 +- camlp4/odyl/Makefile | 26 +- camlp4/odyl/Makefile.Mac | 49 - camlp4/odyl/Makefile.Mac.depend | 4 - camlp4/odyl/odyl.ml | 8 +- camlp4/odyl/odyl_main.ml | 8 +- camlp4/tools/apply.sh | 17 +- camlp4/tools/camlp4_comm.sh | 9 +- camlp4/tools/conv.sh | 2 +- camlp4/top/Makefile | 12 +- camlp4/top/Makefile.Mac | 60 - camlp4/top/Makefile.Mac.depend | 2 - camlp4/top/camlp4_top.ml | 7 +- camlp4/top/rprint.ml | 39 +- camlp4/unmaintained/Makefile | 38 + camlp4/unmaintained/format/.depend | 0 camlp4/unmaintained/format/Makefile | 61 + camlp4/unmaintained/format/README | 15 + .../{etc => unmaintained/format}/pa_format.ml | 17 +- camlp4/unmaintained/lefteval/.depend | 0 camlp4/unmaintained/lefteval/Makefile | 61 + camlp4/unmaintained/lefteval/README | 15 + .../lefteval}/pa_lefteval.ml | 14 +- camlp4/unmaintained/ocamllex/Makefile | 59 + camlp4/unmaintained/ocamllex/README | 15 + .../ocamllex}/pa_ocamllex.ml | 24 +- camlp4/unmaintained/olabl/.depend | 0 camlp4/unmaintained/olabl/Makefile | 61 + camlp4/unmaintained/olabl/README | 15 + .../{etc => unmaintained/olabl}/pa_olabl.ml | 75 +- camlp4/unmaintained/scheme/.depend | 0 camlp4/unmaintained/scheme/Makefile | 85 + camlp4/unmaintained/scheme/README | 15 + .../scheme/pa_scheme.ml} | 42 +- .../scheme/pa_scheme.sc} | 42 +- .../{etc => unmaintained/scheme}/pr_scheme.ml | 23 +- .../scheme}/pr_schp_main.ml | 17 +- camlp4/unmaintained/sml/.depend | 0 camlp4/unmaintained/sml/Makefile | 68 + camlp4/unmaintained/sml/README | 15 + camlp4/{etc => unmaintained/sml}/pa_sml.ml | 17 +- .../lib.sml => unmaintained/sml/smllib.sml} | 17 +- config/Makefile-templ | 32 +- config/Makefile.mingw | 5 +- config/Makefile.msvc | 5 +- config/auto-aux/divmod.c | 2 +- config/auto-aux/hasgot | 3 +- config/{s-MacOS.h => auto-aux/ia32sse2.c} | 18 +- config/config.Mac | 76 - config/gnu/config.guess | 697 +- config/gnu/config.sub | 400 +- config/m-MacOS.h | 33 - config/s-templ.h | 6 +- configure | 200 +- debugger/.depend | 62 +- debugger/Makefile | 7 +- debugger/breakpoints.ml | 27 +- debugger/command_line.ml | 31 +- debugger/lexer.mli | 19 + debugger/main.ml | 12 +- debugger/pos.ml | 37 + debugger/pos.mli | 15 + debugger/time_travel.ml | 6 +- driver/compile.ml | 22 +- driver/compile.mli | 6 +- driver/main.ml | 37 +- driver/optcompile.ml | 24 +- driver/optcompile.mli | 6 +- driver/optmain.ml | 32 +- driver/pparse.ml | 6 +- emacs/caml-emacs.el | 19 +- emacs/caml-font.el | 3 +- emacs/caml-help.el | 109 +- emacs/caml-types.el | 186 +- emacs/caml-xemacs.el | 25 +- emacs/caml.el | 5 +- emacs/camldebug.el | 2 +- lex/.depend | 4 +- lex/Makefile.Mac | 63 - lex/Makefile.Mac.depend | 17 - lex/cset.ml | 5 + lex/cset.mli | 5 + lex/lexer.mli | 6 +- lex/lexer.mll | 110 +- lex/lexgen.ml | 7 +- lex/main.ml | 24 +- lex/output.ml | 6 +- lex/parser.mly | 15 +- 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/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/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/ocamlc.m | 5 +- man/ocamldoc.m | 515 ++ man/ocamlopt.m | 3 +- man/ocamlprof.m | 2 +- man/ocamlrun.m | 11 +- ocamldoc/.cvsignore | 3 + ocamldoc/.depend | 106 +- ocamldoc/Changes.txt | 73 +- ocamldoc/Makefile | 78 +- ocamldoc/Makefile.nt | 93 +- ocamldoc/ocamldoc.hva | 11 +- ocamldoc/odoc.ml | 32 +- ocamldoc/odoc_analyse.ml | 2 + ocamldoc/odoc_analyse.mli | 1 + ocamldoc/odoc_args.ml | 33 +- ocamldoc/odoc_args.mli | 4 + ocamldoc/odoc_ast.ml | 184 +- ocamldoc/odoc_ast.mli | 1 + ocamldoc/odoc_class.ml | 4 +- ocamldoc/odoc_comments.ml | 3 + ocamldoc/odoc_comments.mli | 1 + ocamldoc/odoc_comments_global.ml | 2 + ocamldoc/odoc_comments_global.mli | 1 + ocamldoc/odoc_config.ml | 16 + ocamldoc/odoc_config.mli | 17 + ocamldoc/odoc_control.ml | 2 +- ocamldoc/odoc_cross.ml | 547 +- ocamldoc/odoc_cross.mli | 1 + ocamldoc/odoc_dag2html.ml | 1 + ocamldoc/odoc_dag2html.mli | 1 + ocamldoc/odoc_dep.ml | 8 +- ocamldoc/odoc_dot.ml | 2 + ocamldoc/odoc_env.ml | 11 +- ocamldoc/odoc_env.mli | 1 + ocamldoc/odoc_exception.ml | 2 + ocamldoc/odoc_global.ml | 1 + ocamldoc/odoc_global.mli | 2 + ocamldoc/odoc_html.ml | 2265 ++++--- ocamldoc/odoc_info.ml | 139 +- ocamldoc/odoc_info.mli | 86 +- ocamldoc/odoc_inherit.ml | 2 +- ocamldoc/odoc_latex.ml | 1184 ++-- ocamldoc/odoc_latex_style.ml | 22 +- ocamldoc/odoc_lexer.mll | 2 + ocamldoc/odoc_man.ml | 1059 +-- ocamldoc/odoc_merge.ml | 24 + ocamldoc/odoc_merge.mli | 1 + ocamldoc/odoc_messages.ml | 209 +- ocamldoc/odoc_misc.ml | 99 +- ocamldoc/odoc_misc.mli | 20 +- ocamldoc/odoc_module.ml | 230 +- ocamldoc/odoc_name.ml | 61 +- ocamldoc/odoc_name.mli | 9 +- ocamldoc/odoc_ocamlhtml.mll | 32 +- ocamldoc/odoc_parameter.ml | 11 +- ocamldoc/odoc_parser.mly | 2 + ocamldoc/odoc_print.ml | 104 + ocamldoc/odoc_print.mli | 33 + ocamldoc/odoc_scan.ml | 2 + ocamldoc/odoc_search.ml | 7 +- ocamldoc/odoc_search.mli | 1 + ocamldoc/odoc_see_lexer.mll | 2 + ocamldoc/odoc_sig.ml | 169 +- ocamldoc/odoc_sig.mli | 1 + ocamldoc/odoc_str.ml | 71 +- ocamldoc/odoc_str.mli | 14 +- ocamldoc/odoc_test.ml | 112 + ocamldoc/odoc_texi.ml | 70 +- ocamldoc/odoc_text.ml | 120 + ocamldoc/odoc_text.mli | 6 +- ocamldoc/odoc_text_lexer.mll | 73 +- ocamldoc/odoc_text_parser.mly | 12 +- ocamldoc/odoc_to_text.ml | 58 +- ocamldoc/odoc_type.ml | 1 + ocamldoc/odoc_types.ml | 3 + ocamldoc/odoc_types.mli | 5 + ocamldoc/odoc_value.ml | 14 +- ocamldoc/remove_DEBUG | 15 +- otherlibs/bigarray/.depend | 18 +- otherlibs/bigarray/Makefile.Mac | 53 - otherlibs/bigarray/Makefile.Mac.depend | 42 - otherlibs/bigarray/bigarray_stubs.c | 112 +- otherlibs/dynlink/Makefile | 4 +- otherlibs/dynlink/Makefile.Mac | 56 - otherlibs/dynlink/Makefile.Mac.depend | 4 - otherlibs/dynlink/extract_crc.ml | 6 +- otherlibs/graph/.depend | 86 +- otherlibs/graph/Makefile.Mac.depend | 4 - otherlibs/graph/color.c | 116 +- otherlibs/graph/draw.c | 104 +- otherlibs/graph/dump_img.c | 12 +- otherlibs/graph/events.c | 145 +- otherlibs/graph/fill.c | 52 +- otherlibs/graph/graphics.ml | 74 +- otherlibs/graph/graphics.mli | 62 +- otherlibs/graph/graphicsX11.ml | 8 +- otherlibs/graph/image.c | 66 +- otherlibs/graph/image.h | 4 +- otherlibs/graph/libgraph.h | 61 +- otherlibs/graph/make_img.c | 40 +- otherlibs/graph/open.c | 270 +- otherlibs/graph/point_col.c | 10 +- otherlibs/graph/sound.c | 14 +- otherlibs/graph/subwindow.c | 24 +- otherlibs/graph/text.c | 68 +- otherlibs/labltk/Widgets.src | 16 + otherlibs/labltk/browser/dummyUnix.mli | 4 +- otherlibs/labltk/browser/searchid.ml | 18 +- otherlibs/labltk/browser/searchpos.ml | 73 +- otherlibs/labltk/browser/viewer.ml | 10 +- otherlibs/labltk/browser/winmain.c | 4 +- otherlibs/labltk/examples_labltk/tetris.ml | 10 +- otherlibs/labltk/support/cltkEval.c | 3 +- otherlibs/labltk/support/cltkImg.c | 1 - otherlibs/labltk/tkanim/Makefile | 8 +- otherlibs/labltk/tkanim/tkAnimGIF.c | 1 - otherlibs/macosunix/.cvsignore | 71 - otherlibs/macosunix/Makefile.Mac | 152 - otherlibs/macosunix/Makefile.Mac.depend | 872 --- otherlibs/macosunix/macosunix.c | 119 - otherlibs/macosunix/unix-primitives | 113 - otherlibs/macosunix/unixsupport.h | 43 - otherlibs/num/.cvsignore | 3 + otherlibs/num/.depend | 36 + otherlibs/num/.depend.nt | 56 + otherlibs/num/Makefile | 86 + otherlibs/num/Makefile.nt | 97 + otherlibs/num/README | 55 + otherlibs/num/arith_flags.ml | 25 + otherlibs/num/arith_flags.mli | 20 + otherlibs/num/arith_status.ml | 100 + otherlibs/num/arith_status.mli | 60 + otherlibs/num/big_int.ml | 604 ++ otherlibs/num/big_int.mli | 143 + otherlibs/num/bignum/.cvsignore | 1 + otherlibs/num/bng.c | 434 ++ otherlibs/num/bng.h | 156 + .../clipboard.c => otherlibs/num/bng_alpha.c | 37 +- otherlibs/num/bng_amd64.c | 196 + otherlibs/num/bng_digit.c | 171 + otherlibs/num/bng_ia32.c | 412 ++ otherlibs/num/bng_mips.c | 24 + otherlibs/num/bng_ppc.c | 86 + otherlibs/num/bng_sparc.c | 77 + otherlibs/num/int_misc.ml | 36 + otherlibs/num/int_misc.mli | 25 + maccaml/mcmisc.c => otherlibs/num/nat.h | 17 +- otherlibs/num/nat.ml | 570 ++ otherlibs/num/nat.mli | 71 + otherlibs/num/nat_stubs.c | 369 ++ otherlibs/num/num.ml | 396 ++ otherlibs/num/num.mli | 171 + otherlibs/num/ratio.ml | 577 ++ otherlibs/num/ratio.mli | 88 + .../string_misc.ml} | 13 +- .../string_misc.mli} | 8 +- otherlibs/num/test/.depend | 10 + otherlibs/num/test/Makefile | 61 + otherlibs/num/test/Makefile.nt | 61 + otherlibs/num/test/end_test.ml | 1 + otherlibs/num/test/test.ml | 77 + otherlibs/num/test/test_big_ints.ml | 468 ++ otherlibs/num/test/test_bng.c | 408 ++ otherlibs/num/test/test_io.ml | 64 + otherlibs/num/test/test_nats.ml | 142 + otherlibs/num/test/test_nums.ml | 220 + otherlibs/num/test/test_ratios.ml | 928 +++ otherlibs/str/.depend | 10 +- otherlibs/str/Makefile.Mac | 53 - otherlibs/str/Makefile.Mac.depend | 16 - otherlibs/str/str.ml | 14 +- otherlibs/str/str.mli | 52 +- otherlibs/str/strstubs.c | 7 +- otherlibs/systhreads/.depend | 12 +- otherlibs/systhreads/Makefile.Mac | 78 - otherlibs/systhreads/Makefile.Mac.depend | 131 - otherlibs/systhreads/Tests/Makefile | 44 + otherlibs/systhreads/Tests/Makefile.nt | 43 + otherlibs/systhreads/posix.c | 85 +- otherlibs/systhreads/win32.c | 10 +- otherlibs/threads/.depend | 3 +- otherlibs/threads/Tests/.cvsignore | 1 + otherlibs/threads/Tests/Makefile | 38 + otherlibs/threads/Tests/close.ml | 14 + otherlibs/threads/Tests/sieve.ml | 33 + otherlibs/threads/Tests/sorts.ml | 228 + otherlibs/threads/Tests/test1.ml | 57 + otherlibs/threads/Tests/test2.ml | 15 + otherlibs/threads/Tests/test3.ml | 8 + otherlibs/threads/Tests/test4.ml | 13 + otherlibs/threads/Tests/test5.ml | 21 + otherlibs/threads/Tests/test6.ml | 17 + otherlibs/threads/Tests/test7.ml | 28 + otherlibs/threads/Tests/test8.ml | 46 + otherlibs/threads/Tests/test9.ml | 26 + otherlibs/threads/Tests/testA.ml | 24 + otherlibs/threads/Tests/testexit.ml | 22 + otherlibs/threads/Tests/testio.ml | 119 + otherlibs/threads/Tests/testsieve.ml | 42 + otherlibs/threads/Tests/testsignal.ml | 13 + otherlibs/threads/Tests/testsignal2.ml | 10 + otherlibs/threads/Tests/testsocket.ml | 31 + otherlibs/threads/Tests/token1.ml | 36 + otherlibs/threads/Tests/token2.ml | 36 + otherlibs/threads/Tests/torture.ml | 46 + otherlibs/threads/marshal.ml | 11 +- otherlibs/threads/pervasives.ml | 166 +- otherlibs/threads/scheduler.c | 4 +- otherlibs/threads/thread.mli | 4 +- otherlibs/threads/threadUnix.ml | 3 +- otherlibs/threads/threadUnix.mli | 3 +- otherlibs/threads/unix.ml | 191 +- otherlibs/unix/.depend | 564 +- otherlibs/unix/Makefile | 9 +- otherlibs/unix/addrofstr.c | 23 +- otherlibs/unix/closedir.c | 10 +- otherlibs/unix/cst2constr.h | 8 +- otherlibs/unix/errmsg.c | 25 +- otherlibs/unix/getaddrinfo.c | 133 + otherlibs/unix/gethost.c | 15 +- otherlibs/unix/getnameinfo.c | 67 + otherlibs/unix/getpeername.c | 4 +- otherlibs/unix/itimer.c | 24 +- otherlibs/unix/lockf.c | 7 +- otherlibs/unix/opendir.c | 8 +- otherlibs/unix/readdir.c | 9 +- otherlibs/unix/rewinddir.c | 9 +- otherlibs/unix/socket.c | 11 +- otherlibs/unix/socketaddr.c | 59 +- otherlibs/unix/socketaddr.h | 21 +- otherlibs/unix/strofaddr.c | 21 +- otherlibs/unix/unix.ml | 186 +- otherlibs/unix/unix.mli | 157 +- otherlibs/unix/unixLabels.mli | 114 +- otherlibs/unix/unixsupport.h | 4 +- otherlibs/unix/write.c | 33 +- otherlibs/win32graph/Makefile.nt | 4 +- otherlibs/win32graph/draw.c | 226 +- otherlibs/win32graph/events.c | 200 + otherlibs/win32graph/libgraph.h | 16 +- otherlibs/win32graph/open.c | 92 +- otherlibs/win32unix/Makefile.nt | 4 +- otherlibs/win32unix/errmsg.c | 2 +- otherlibs/win32unix/rename.c | 22 +- otherlibs/win32unix/socketaddr.h | 15 +- otherlibs/win32unix/unix.ml | 162 +- otherlibs/win32unix/unixsupport.c | 3 +- otherlibs/win32unix/write.c | 43 +- parsing/lexer.mli | 3 +- parsing/lexer.mll | 54 +- parsing/location.ml | 6 +- parsing/parser.mly | 21 +- parsing/parsetree.mli | 3 +- parsing/printast.ml | 5 +- stdlib/.cvsignore | 1 + stdlib/.depend | 21 +- stdlib/Compflags | 26 + stdlib/Makefile | 95 +- stdlib/Makefile.Mac | 74 - stdlib/Makefile.Mac.depend | 74 - stdlib/Makefile.nt | 72 +- stdlib/StdlibModules | 3 +- stdlib/arg.ml | 84 +- stdlib/arg.mli | 10 +- stdlib/array.ml | 6 +- stdlib/array.mli | 18 +- stdlib/arrayLabels.mli | 6 +- stdlib/buffer.ml | 26 +- stdlib/buffer.mli | 12 + stdlib/callback.ml | 5 +- stdlib/camlinternalOO.ml | 542 +- stdlib/camlinternalOO.mli | 104 +- stdlib/char.ml | 6 +- stdlib/digest.ml | 6 +- stdlib/digest.mli | 4 +- stdlib/filename.ml | 164 +- stdlib/filename.mli | 12 +- stdlib/format.ml | 226 +- stdlib/format.mli | 28 +- stdlib/gc.ml | 24 +- stdlib/gc.mli | 56 +- stdlib/hashtbl.ml | 28 +- stdlib/hashtbl.mli | 19 +- stdlib/int32.ml | 12 +- stdlib/int32.mli | 25 +- stdlib/int64.ml | 14 +- stdlib/int64.mli | 17 +- stdlib/lazy.ml | 41 +- stdlib/lexing.ml | 7 +- stdlib/list.ml | 12 +- stdlib/list.mli | 5 +- stdlib/map.ml | 43 +- stdlib/map.mli | 35 +- stdlib/marshal.ml | 15 +- stdlib/marshal.mli | 4 +- stdlib/moreLabels.mli | 12 +- stdlib/nativeint.ml | 10 +- stdlib/nativeint.mli | 13 +- stdlib/obj.ml | 18 +- stdlib/obj.mli | 17 +- stdlib/oo.ml | 4 +- stdlib/oo.mli | 6 +- stdlib/parsing.ml | 4 +- stdlib/parsing.mli | 4 +- stdlib/pervasives.ml | 163 +- stdlib/pervasives.mli | 120 +- stdlib/printexc.ml | 10 +- stdlib/printf.ml | 15 +- stdlib/random.ml | 4 +- stdlib/scanf.ml | 580 +- stdlib/scanf.mli | 34 +- stdlib/set.ml | 34 +- stdlib/set.mli | 23 +- stdlib/sort.ml | 5 +- stdlib/stdLabels.mli | 19 +- stdlib/string.ml | 10 +- stdlib/string.mli | 26 +- stdlib/stringLabels.ml | 4 +- stdlib/stringLabels.mli | 16 +- stdlib/sys.ml | 30 +- stdlib/sys.mli | 44 +- stdlib/weak.ml | 12 +- stdlib/weak.mli | 4 +- test/.cvsignore | 2 + test/.depend | 28 + test/KB/equations.ml | 115 + test/KB/equations.mli | 32 + test/KB/kb.ml | 188 + test/KB/kb.mli | 29 + test/KB/kbmain.ml | 81 + test/KB/orderings.ml | 99 + test/KB/orderings.mli | 31 + test/KB/terms.ml | 137 + test/KB/terms.mli | 31 + test/Lex/.cvsignore | 5 + test/Lex/gram_aux.ml | 47 + test/Lex/grammar.mly | 114 + test/Lex/lexgen.ml | 266 + test/Lex/main.ml | 118 + test/Lex/output.ml | 169 + test/Lex/scan_aux.ml | 60 + test/Lex/scanner.mll | 132 + test/Lex/syntax.ml | 40 + test/Lex/testmain.ml | 48 + test/Lex/testscanner.mll | 135 + test/Makefile | 195 + test/Moretest/.cvsignore | 2 + test/Moretest/.depend | 6 + test/Moretest/Makefile | 177 + test/Moretest/arrays.ml | 86 + test/Moretest/bigarrays.ml | 720 ++ test/Moretest/bigarrf.f | 26 + test/Moretest/bigarrfml.ml | 63 + test/Moretest/bigarrfstub.c | 60 + test/Moretest/bigints.ml | 12 + test/Moretest/bounds.ml | 28 + test/Moretest/boxedints.ml | 569 ++ test/Moretest/callback.ml | 69 + test/Moretest/callbackprim.c | 54 + test/Moretest/cmcaml.ml | 17 + test/Moretest/cmmain.c | 21 + test/Moretest/cmstub.c | 17 + test/Moretest/equality.ml | 71 + test/Moretest/fftba.ml | 191 + test/Moretest/float.ml | 1 + test/Moretest/globroots.ml | 25 + test/Moretest/globrootsprim.c | 29 + test/Moretest/graph_example.ml | 131 + test/Moretest/graph_test.ml | 288 + test/Moretest/includestruct.ml | 92 + test/Moretest/intext.ml | 454 ++ test/Moretest/intextaux.c | 13 + test/Moretest/io.ml | 101 + test/Moretest/manyargs.ml | 18 + test/Moretest/manyargsprim.c | 24 + test/Moretest/md5.ml | 219 + test/Moretest/morematch.ml | 1137 ++++ test/Moretest/multdef.ml | 2 + test/Moretest/multdef.mli | 3 + test/Moretest/patmatch.ml | 78 + test/Moretest/recvalues.ml | 38 + test/Moretest/regexp.ml | 975 +++ test/Moretest/sets.ml | 39 + test/Moretest/signals.ml | 32 + test/Moretest/stackoverflow.ml | 15 + test/Moretest/syserror.ml | 1 + test/Moretest/tailcalls.ml | 28 + test/Moretest/testrandom.ml | 13 + test/Moretest/tscanf.ml | 848 +++ test/Moretest/usemultdef.ml | 1 + test/Moretest/warnings.ml | 44 + test/Moretest/wc.ml | 54 + test/Results/almabench.fast.out | 8 + test/Results/almabench.out | 8 + test/Results/bdd.out | 1 + test/Results/boyer.out | 1 + test/Results/fft.fast.runtest | 4 + test/Results/fft.runtest | 4 + test/Results/fib.out | 1 + test/Results/genlex.runtest | 5 + test/Results/hamming.out | 100 + test/Results/kb.out | 273 + test/Results/nucleic.out | 1 + test/Results/quicksort.fast.out | 2 + test/Results/quicksort.out | 2 + test/Results/sieve.out | 1 + test/Results/soli.fast.out | 50 + test/Results/soli.out | 50 + test/Results/sorts.out | 198 + test/Results/takc.out | 1 + test/Results/taku.out | 1 + test/alloc.ml | 51 + test/almabench.ml | 324 + test/bdd.ml | 231 + test/boyer.ml | 907 +++ test/fft.ml | 188 + test/fib.ml | 24 + test/hamming.ml | 105 + test/nucleic.ml | 3236 +++++++++ test/ocamldoc/Makefile | 40 + test/ocamldoc/t1.ml | 19 + test/quicksort.ml | 92 + test/sieve.ml | 56 + test/soli.ml | 111 + test/sorts.ml | 4477 +++++++++++++ test/takc.ml | 23 + test/taku.ml | 22 + test/testinterp/.cvsignore | 3 + .../testinterp/addbytecode.mpw | 44 +- test/testinterp/coverage | 133 + test/testinterp/lib.ml | 46 + test/testinterp/no68k.rez | 1 + test/testinterp/noppc.rez | 1 + test/testinterp/runtest.mpw | 105 + test/testinterp/t000.ml | 7 + test/testinterp/t010-const0.ml | 8 + test/testinterp/t010-const1.ml | 8 + test/testinterp/t010-const2.ml | 8 + test/testinterp/t010-const3.ml | 8 + test/testinterp/t011-constint.ml | 8 + test/testinterp/t020.ml | 10 + test/testinterp/t021-pushconst1.ml | 10 + test/testinterp/t021-pushconst2.ml | 10 + test/testinterp/t021-pushconst3.ml | 10 + test/testinterp/t022-pushconstint.ml | 10 + test/testinterp/t040-makeblock1.ml | 13 + test/testinterp/t040-makeblock2.ml | 15 + test/testinterp/t040-makeblock3.ml | 17 + test/testinterp/t041-makeblock.ml | 19 + test/testinterp/t050-getglobal.ml | 8 + test/testinterp/t050-pushgetglobal.ml | 10 + test/testinterp/t051-getglobalfield.ml | 13 + test/testinterp/t051-pushgetglobalfield.ml | 15 + test/testinterp/t060-raise.ml | 15 + test/testinterp/t070-branch.ml | 20 + test/testinterp/t070-branchif.ml | 20 + test/testinterp/t070-branchifnot.ml | 18 + test/testinterp/t071-boolnot.ml | 19 + test/testinterp/t080-eq.ml | 21 + test/testinterp/t080-geint.ml | 21 + test/testinterp/t080-gtint.ml | 20 + test/testinterp/t080-leint.ml | 21 + test/testinterp/t080-ltint.ml | 20 + test/testinterp/t080-neq.ml | 20 + test/testinterp/t090-acc0.ml | 25 + test/testinterp/t090-acc1.ml | 27 + test/testinterp/t090-acc2.ml | 29 + test/testinterp/t090-acc3.ml | 31 + test/testinterp/t090-acc4.ml | 33 + test/testinterp/t090-acc5.ml | 35 + test/testinterp/t090-acc6.ml | 37 + test/testinterp/t090-acc7.ml | 39 + test/testinterp/t091-acc.ml | 41 + test/testinterp/t092-pushacc.ml | 38 + test/testinterp/t092-pushacc0.ml | 22 + test/testinterp/t092-pushacc1.ml | 24 + test/testinterp/t092-pushacc2.ml | 26 + test/testinterp/t092-pushacc3.ml | 28 + test/testinterp/t092-pushacc4.ml | 30 + test/testinterp/t092-pushacc5.ml | 32 + test/testinterp/t092-pushacc6.ml | 34 + test/testinterp/t092-pushacc7.ml | 36 + test/testinterp/t093-pushacc.ml | 38 + test/testinterp/t100-pushtrap.ml | 21 + test/testinterp/t101-poptrap.ml | 21 + test/testinterp/t110-addint.ml | 26 + test/testinterp/t110-andint.ml | 22 + test/testinterp/t110-asrint-1.ml | 22 + test/testinterp/t110-asrint-2.ml | 22 + test/testinterp/t110-divint-1.ml | 22 + test/testinterp/t110-divint-2.ml | 22 + test/testinterp/t110-divint-3.ml | 33 + test/testinterp/t110-lslint.ml | 22 + test/testinterp/t110-lsrint.ml | 22 + test/testinterp/t110-modint-1.ml | 22 + test/testinterp/t110-modint-2.ml | 34 + test/testinterp/t110-mulint.ml | 22 + test/testinterp/t110-negint.ml | 25 + test/testinterp/t110-offsetint.ml | 21 + test/testinterp/t110-orint.ml | 22 + test/testinterp/t110-subint.ml | 26 + test/testinterp/t110-xorint.ml | 22 + test/testinterp/t120-getstringchar.ml | 22 + test/testinterp/t121-setstringchar.ml | 31 + test/testinterp/t130-getvectitem.ml | 24 + test/testinterp/t130-vectlength.ml | 23 + test/testinterp/t131-setvectitem.ml | 33 + test/testinterp/t140-switch-1.ml | 32 + test/testinterp/t140-switch-2.ml | 32 + test/testinterp/t140-switch-3.ml | 31 + test/testinterp/t140-switch-4.ml | 31 + test/testinterp/t141-switch-5.ml | 38 + test/testinterp/t141-switch-6.ml | 38 + test/testinterp/t141-switch-7.ml | 37 + test/testinterp/t142-switch-8.ml | 34 + test/testinterp/t142-switch-9.ml | 34 + test/testinterp/t142-switch-A.ml | 34 + test/testinterp/t150-push-1.ml | 24 + test/testinterp/t150-push-2.ml | 39 + test/testinterp/t160-closure.ml | 19 + test/testinterp/t161-apply1.ml | 42 + test/testinterp/t162-return.ml | 21 + test/testinterp/t163.ml | 23 + test/testinterp/t164-apply2.ml | 24 + test/testinterp/t164-apply3.ml | 25 + test/testinterp/t165-apply.ml | 28 + test/testinterp/t170-envacc2.ml | 37 + test/testinterp/t170-envacc3.ml | 42 + test/testinterp/t170-envacc4.ml | 47 + test/testinterp/t171-envacc.ml | 52 + test/testinterp/t172-pushenvacc1.ml | 34 + test/testinterp/t172-pushenvacc2.ml | 37 + test/testinterp/t172-pushenvacc3.ml | 42 + test/testinterp/t172-pushenvacc4.ml | 47 + test/testinterp/t173-pushenvacc.ml | 52 + test/testinterp/t180-appterm1.ml | 35 + test/testinterp/t180-appterm2.ml | 38 + test/testinterp/t180-appterm3.ml | 39 + test/testinterp/t181-appterm.ml | 40 + test/testinterp/t190-makefloatblock-1.ml | 17 + test/testinterp/t190-makefloatblock-2.ml | 18 + test/testinterp/t190-makefloatblock-3.ml | 19 + test/testinterp/t191-vectlength.ml | 26 + test/testinterp/t192-getfloatfield-1.ml | 23 + test/testinterp/t192-getfloatfield-2.ml | 23 + test/testinterp/t193-setfloatfield-1.ml | 36 + test/testinterp/t193-setfloatfield-2.ml | 36 + test/testinterp/t200-getfield0.ml | 25 + test/testinterp/t200-getfield1.ml | 26 + test/testinterp/t200-getfield2.ml | 27 + test/testinterp/t200-getfield3.ml | 28 + test/testinterp/t201-getfield.ml | 29 + test/testinterp/t210-setfield0.ml | 36 + test/testinterp/t210-setfield1.ml | 38 + test/testinterp/t210-setfield2.ml | 40 + test/testinterp/t210-setfield3.ml | 42 + test/testinterp/t211-setfield.ml | 44 + test/testinterp/t220-assign.ml | 27 + test/testinterp/t230-check_signals.ml | 28 + test/testinterp/t240-c_call1.ml | 21 + test/testinterp/t240-c_call2.ml | 22 + test/testinterp/t240-c_call3.ml | 23 + test/testinterp/t240-c_call4.ml | 32 + test/testinterp/t240-c_call5.ml | 33 + test/testinterp/t250-closurerec-1.ml | 19 + test/testinterp/t250-closurerec-2.ml | 29 + test/testinterp/t251-pushoffsetclosure0.ml | 39 + test/testinterp/t251-pushoffsetclosure2.ml | 34 + test/testinterp/t251-pushoffsetclosurem2.ml | 34 + test/testinterp/t252-pushoffsetclosure.ml | 38 + test/testinterp/t253-offsetclosure0.ml | 34 + test/testinterp/t253-offsetclosure2.ml | 34 + test/testinterp/t253-offsetclosurem2.ml | 34 + test/testinterp/t254-offsetclosure.ml | 37 + test/testinterp/t260-offsetref.ml | 31 + test/testinterp/t270-push_retaddr.ml | 36 + test/testinterp/t300-getmethod.ml | 5885 +++++++++++++++++ test/testinterp/t301-object.ml | 29 + test/testinterp/t310-alloc-1.ml | 1587 +++++ test/testinterp/t310-alloc-2.ml | 2313 +++++++ test/testinterp/t320-gc-1.ml | 1589 +++++ test/testinterp/t320-gc-2.ml | 1589 +++++ test/testinterp/t320-gc-3.ml | 1589 +++++ test/testinterp/t330-compact-1.ml | 15 + test/testinterp/t330-compact-2.ml | 755 +++ test/testinterp/t330-compact-3.ml | 1589 +++++ test/testinterp/t330-compact-4.ml | 1589 +++++ test/testinterp/t340-weak.ml | 2551 +++++++ test/testinterp/t350-heapcheck.ml | 2554 +++++++ test/testinterp/t360-stacks-1.ml | 43 + test/testinterp/t360-stacks-2.ml | 54 + testasmcomp/.cvsignore | 5 + testasmcomp/.depend | 17 + testasmcomp/Makefile | 159 + testasmcomp/alpha.S | 62 + testasmcomp/amd64.S | 53 + testasmcomp/arith.cmm | 222 + testasmcomp/arm.S | 45 + testasmcomp/checkbound.cmm | 21 + testasmcomp/fib.cmm | 19 + testasmcomp/hppa.S | 162 + testasmcomp/i386.S | 56 + testasmcomp/i386nt.asm | 67 + testasmcomp/ia64.S | 118 + testasmcomp/integr.cmm | 30 + testasmcomp/lexcmm.mli | 24 + testasmcomp/lexcmm.mll | 228 + testasmcomp/m68k.S | 59 + testasmcomp/main.c | 126 + testasmcomp/main.ml | 60 + testasmcomp/mainarith.c | 304 + testasmcomp/mips.s | 71 + testasmcomp/parsecmm.mly | 325 + testasmcomp/parsecmmaux.ml | 40 + testasmcomp/parsecmmaux.mli | 26 + testasmcomp/power-aix.S | 152 + testasmcomp/power-elf.S | 131 + testasmcomp/power-rhapsody.S | 129 + testasmcomp/quicksort.cmm | 43 + testasmcomp/quicksort2.cmm | 49 + testasmcomp/soli.cmm | 109 + testasmcomp/sparc.S | 41 + testasmcomp/tagged-fib.cmm | 19 + testasmcomp/tagged-integr.cmm | 45 + testasmcomp/tagged-quicksort.cmm | 46 + testasmcomp/tagged-tak.cmm | 23 + testasmcomp/tak.cmm | 23 + testlabl/.cvsignore | 1 + testlabl/Makefile | 17 + testlabl/bugs/yamagata021012.ml | 193 + testlabl/dirs_multimatch | 1 + testlabl/dirs_poly | 1 + testlabl/mixin.ml | 146 + testlabl/mixin2.ml | 179 + testlabl/mixin3.ml | 173 + testlabl/multimatch.ml | 157 + testlabl/newlabels.ps | 1458 ++++ testlabl/objvariant.ml | 42 + testlabl/poly.exp | 350 + testlabl/poly.exp2 | 357 + testlabl/poly.ml | 488 ++ testlabl/printers.ml | 11 + testlabl/tests.ml | 22 + testobjects/.cvsignore | 1 + testobjects/Exemples.exp | 301 + testobjects/Exemples.ml | 333 + testobjects/Makefile | 25 + testobjects/Tests.exp | 228 + testobjects/Tests.ml | 316 + tools/Makefile | 15 +- tools/Makefile.Mac | 137 - tools/Makefile.Mac.depend | 30 - tools/addlabels.ml | 4 +- tools/depend.ml | 5 +- tools/dumpobj.ml | 32 +- tools/lexer299.mll | 40 +- tools/lexer301.mll | 27 +- tools/make-opcodes.Mac | 14 - tools/make-package-macosx | 112 +- tools/ocamldep.ml | 8 +- tools/ocamlmklib.mlp | 24 +- tools/ocamlmktop.tpl | 14 +- tools/ocamlprof.ml | 27 +- toplevel/expunge.ml | 7 +- toplevel/genprintval.ml | 6 +- toplevel/topdirs.ml | 24 +- toplevel/toploop.ml | 73 +- toplevel/toploop.mli | 6 +- typing/btype.ml | 81 +- typing/btype.mli | 5 +- typing/ctype.ml | 183 +- typing/ctype.mli | 6 +- typing/env.ml | 48 +- typing/env.mli | 3 +- typing/ident.ml | 37 +- typing/ident.mli | 5 +- typing/includemod.ml | 52 +- typing/mtype.ml | 74 +- typing/mtype.mli | 9 +- typing/oprint.ml | 33 +- typing/outcometree.mli | 16 +- typing/parmatch.ml | 79 +- typing/predef.ml | 27 +- typing/printtyp.ml | 300 +- typing/printtyp.mli | 11 +- typing/subst.ml | 30 +- typing/typeclass.ml | 275 +- typing/typeclass.mli | 5 +- typing/typecore.ml | 123 +- typing/typecore.mli | 8 +- typing/typedecl.ml | 10 +- typing/typedtree.ml | 6 +- typing/typedtree.mli | 6 +- typing/typemod.ml | 138 +- typing/typemod.mli | 4 +- typing/types.ml | 20 +- typing/types.mli | 20 +- utils/ccomp.ml | 4 +- utils/config.mlp | 14 +- utils/misc.ml | 13 +- utils/misc.mli | 5 +- utils/terminfo.ml | 10 +- utils/terminfo.mli | 10 +- win32caml/Makefile | 7 +- win32caml/editbuffer.c | 514 ++ win32caml/editbuffer.h | 47 + win32caml/history.c | 98 + win32caml/history.h | 35 + win32caml/inria.h | 35 +- win32caml/menu.c | 324 +- win32caml/ocaml.c | 1957 ++++-- win32caml/ocaml.rc | 369 +- win32caml/resource.h | 16 + win32caml/startocaml.c | 536 +- yacc/Makefile.Mac | 54 - yacc/defs.h | 22 +- yacc/error.c | 58 +- yacc/main.c | 3 +- yacc/reader.c | 72 +- 1129 files changed, 92124 insertions(+), 34781 deletions(-) delete mode 100644 INSTALL.MPW delete mode 100644 Makefile.Mac delete mode 100644 Makefile.Mac.depend delete mode 100644 byterun/Makefile.Mac delete mode 100644 byterun/Makefile.Mac.depend rename byterun/{macintosh.h => compare.h} (71%) create mode 100644 byterun/compatibility.h delete mode 100644 byterun/macintosh.c delete mode 100644 byterun/mpwtool.c delete mode 100644 byterun/rotatecursor.c delete mode 100644 byterun/rotatecursor.h delete mode 100644 camlp4/Makefile.Mac delete mode 100644 camlp4/camlp4/Makefile.Mac delete mode 100644 camlp4/camlp4/Makefile.Mac.depend delete mode 100644 camlp4/etc/Makefile.Mac delete mode 100644 camlp4/etc/Makefile.Mac.depend delete mode 100644 camlp4/etc/pa_lisp.ml delete mode 100644 camlp4/etc/pa_lispr.ml delete mode 100644 camlp4/lib/Makefile.Mac delete mode 100644 camlp4/lib/Makefile.Mac.depend delete mode 100644 camlp4/man/Makefile.Mac delete mode 100644 camlp4/meta/Makefile.Mac delete mode 100644 camlp4/meta/Makefile.Mac.depend delete mode 100755 camlp4/meta/mk_q_MLast.sh delete mode 100644 camlp4/meta/pa_ifdef.ml delete mode 100644 camlp4/ocaml_src/camlp4/Makefile.Mac delete mode 100644 camlp4/ocaml_src/camlp4/Makefile.Mac.depend delete mode 100644 camlp4/ocaml_src/lib/Makefile.Mac delete mode 100644 camlp4/ocaml_src/lib/Makefile.Mac.depend delete mode 100644 camlp4/ocaml_src/meta/Makefile.Mac delete mode 100644 camlp4/ocaml_src/meta/Makefile.Mac.depend delete mode 100644 camlp4/ocaml_src/meta/pa_ifdef.ml delete mode 100644 camlp4/ocaml_src/odyl/Makefile.Mac delete mode 100644 camlp4/ocaml_src/odyl/Makefile.Mac.depend delete mode 100644 camlp4/ocpp/Makefile.Mac delete mode 100644 camlp4/odyl/Makefile.Mac delete mode 100644 camlp4/odyl/Makefile.Mac.depend delete mode 100644 camlp4/top/Makefile.Mac delete mode 100644 camlp4/top/Makefile.Mac.depend create mode 100644 camlp4/unmaintained/Makefile create mode 100644 camlp4/unmaintained/format/.depend create mode 100644 camlp4/unmaintained/format/Makefile create mode 100644 camlp4/unmaintained/format/README rename camlp4/{etc => unmaintained/format}/pa_format.ml (54%) create mode 100644 camlp4/unmaintained/lefteval/.depend create mode 100644 camlp4/unmaintained/lefteval/Makefile create mode 100644 camlp4/unmaintained/lefteval/README rename camlp4/{etc => unmaintained/lefteval}/pa_lefteval.ml (94%) create mode 100644 camlp4/unmaintained/ocamllex/Makefile create mode 100644 camlp4/unmaintained/ocamllex/README rename camlp4/{etc => unmaintained/ocamllex}/pa_ocamllex.ml (89%) create mode 100644 camlp4/unmaintained/olabl/.depend create mode 100644 camlp4/unmaintained/olabl/Makefile create mode 100644 camlp4/unmaintained/olabl/README rename camlp4/{etc => unmaintained/olabl}/pa_olabl.ml (96%) create mode 100644 camlp4/unmaintained/scheme/.depend create mode 100644 camlp4/unmaintained/scheme/Makefile create mode 100644 camlp4/unmaintained/scheme/README rename camlp4/{etc/pa_schemer.ml => unmaintained/scheme/pa_scheme.ml} (94%) rename camlp4/{etc/pa_scheme.ml => unmaintained/scheme/pa_scheme.sc} (94%) rename camlp4/{etc => unmaintained/scheme}/pr_scheme.ml (96%) rename camlp4/{etc => unmaintained/scheme}/pr_schp_main.ml (77%) create mode 100644 camlp4/unmaintained/sml/.depend create mode 100644 camlp4/unmaintained/sml/Makefile create mode 100644 camlp4/unmaintained/sml/README rename camlp4/{etc => unmaintained/sml}/pa_sml.ml (97%) rename camlp4/{etc/lib.sml => unmaintained/sml/smllib.sml} (91%) rename config/{s-MacOS.h => auto-aux/ia32sse2.c} (64%) delete mode 100644 config/config.Mac delete mode 100644 config/m-MacOS.h create mode 100644 debugger/lexer.mli create mode 100644 debugger/pos.ml create mode 100644 debugger/pos.mli delete mode 100644 lex/Makefile.Mac delete mode 100644 lex/Makefile.Mac.depend delete mode 100644 maccaml/.cvsignore delete mode 100644 maccaml/Makefile.Mac delete mode 100644 maccaml/Makefile.Mac.depend delete mode 100644 maccaml/SHORTCUTS delete mode 100644 maccaml/WASTE/.cvsignore delete mode 100644 maccaml/WASTE/Makefile delete mode 100644 maccaml/WASTE/README delete mode 100644 maccaml/aboutbox.c delete mode 100644 maccaml/appleevents.c delete mode 100644 maccaml/appli.r delete mode 100644 maccaml/drag.c delete mode 100644 maccaml/dummy_fragment.c delete mode 100644 maccaml/errors.c delete mode 100644 maccaml/events.c delete mode 100644 maccaml/files.c delete mode 100644 maccaml/glue.c delete mode 100644 maccaml/graph.c delete mode 100644 maccaml/lcontrols.c delete mode 100644 maccaml/lib.c delete mode 100644 maccaml/main.c delete mode 100644 maccaml/main.h delete mode 100644 maccaml/mcmemory.c delete mode 100644 maccaml/menus.c delete mode 100644 maccaml/modalfilter.c delete mode 100644 maccaml/ocaml.r delete mode 100644 maccaml/ocamlconstants.h delete mode 100644 maccaml/ocamlmkappli delete mode 100644 maccaml/prefs.c delete mode 100644 maccaml/prim_bigarray delete mode 100644 maccaml/prim_graph delete mode 100644 maccaml/prim_num delete mode 100644 maccaml/prim_str delete mode 100644 maccaml/print.c delete mode 100644 maccaml/scroll.c delete mode 100644 maccaml/windows.c create mode 100644 man/ocamldoc.m create mode 100644 ocamldoc/odoc_config.ml create mode 100644 ocamldoc/odoc_config.mli create mode 100644 ocamldoc/odoc_print.ml create mode 100644 ocamldoc/odoc_print.mli create mode 100644 ocamldoc/odoc_test.ml delete mode 100644 otherlibs/bigarray/Makefile.Mac delete mode 100644 otherlibs/bigarray/Makefile.Mac.depend delete mode 100644 otherlibs/dynlink/Makefile.Mac delete mode 100644 otherlibs/dynlink/Makefile.Mac.depend delete mode 100644 otherlibs/graph/Makefile.Mac.depend delete mode 100644 otherlibs/macosunix/.cvsignore delete mode 100644 otherlibs/macosunix/Makefile.Mac delete mode 100644 otherlibs/macosunix/Makefile.Mac.depend delete mode 100644 otherlibs/macosunix/macosunix.c delete mode 100644 otherlibs/macosunix/unix-primitives delete 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.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/bng.c create mode 100644 otherlibs/num/bng.h rename maccaml/clipboard.c => otherlibs/num/bng_alpha.c (51%) create mode 100644 otherlibs/num/bng_amd64.c create mode 100644 otherlibs/num/bng_digit.c create mode 100644 otherlibs/num/bng_ia32.c create mode 100644 otherlibs/num/bng_mips.c create mode 100644 otherlibs/num/bng_ppc.c create mode 100644 otherlibs/num/bng_sparc.c create mode 100644 otherlibs/num/int_misc.ml create mode 100644 otherlibs/num/int_misc.mli rename maccaml/mcmisc.c => otherlibs/num/nat.h (63%) 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 rename otherlibs/{macosunix/macosunix_startup.ml => num/string_misc.ml} (67%) rename otherlibs/{macosunix/macosunix_startup.mli => num/string_misc.mli} (74%) create mode 100644 otherlibs/num/test/.depend create mode 100644 otherlibs/num/test/Makefile 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_bng.c 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 delete mode 100644 otherlibs/str/Makefile.Mac delete mode 100644 otherlibs/str/Makefile.Mac.depend delete mode 100644 otherlibs/systhreads/Makefile.Mac delete mode 100644 otherlibs/systhreads/Makefile.Mac.depend create mode 100644 otherlibs/systhreads/Tests/Makefile create mode 100644 otherlibs/systhreads/Tests/Makefile.nt create mode 100644 otherlibs/threads/Tests/.cvsignore create mode 100644 otherlibs/threads/Tests/Makefile create mode 100644 otherlibs/threads/Tests/close.ml create mode 100644 otherlibs/threads/Tests/sieve.ml create mode 100644 otherlibs/threads/Tests/sorts.ml create mode 100644 otherlibs/threads/Tests/test1.ml create mode 100644 otherlibs/threads/Tests/test2.ml create mode 100644 otherlibs/threads/Tests/test3.ml create mode 100644 otherlibs/threads/Tests/test4.ml create mode 100644 otherlibs/threads/Tests/test5.ml create mode 100644 otherlibs/threads/Tests/test6.ml create mode 100644 otherlibs/threads/Tests/test7.ml create mode 100644 otherlibs/threads/Tests/test8.ml create mode 100644 otherlibs/threads/Tests/test9.ml create mode 100644 otherlibs/threads/Tests/testA.ml create mode 100644 otherlibs/threads/Tests/testexit.ml create mode 100644 otherlibs/threads/Tests/testio.ml create mode 100644 otherlibs/threads/Tests/testsieve.ml create mode 100644 otherlibs/threads/Tests/testsignal.ml create mode 100644 otherlibs/threads/Tests/testsignal2.ml create mode 100644 otherlibs/threads/Tests/testsocket.ml create mode 100644 otherlibs/threads/Tests/token1.ml create mode 100644 otherlibs/threads/Tests/token2.ml create mode 100644 otherlibs/threads/Tests/torture.ml create mode 100644 otherlibs/unix/getaddrinfo.c create mode 100644 otherlibs/unix/getnameinfo.c create mode 100755 otherlibs/win32graph/events.c create mode 100755 stdlib/Compflags delete mode 100644 stdlib/Makefile.Mac delete mode 100644 stdlib/Makefile.Mac.depend create mode 100644 test/.cvsignore create mode 100644 test/.depend create mode 100644 test/KB/equations.ml create mode 100644 test/KB/equations.mli create mode 100644 test/KB/kb.ml create mode 100644 test/KB/kb.mli create mode 100644 test/KB/kbmain.ml create mode 100644 test/KB/orderings.ml create mode 100644 test/KB/orderings.mli create mode 100644 test/KB/terms.ml create mode 100644 test/KB/terms.mli create mode 100644 test/Lex/.cvsignore create mode 100644 test/Lex/gram_aux.ml create mode 100644 test/Lex/grammar.mly create mode 100644 test/Lex/lexgen.ml create mode 100644 test/Lex/main.ml create mode 100644 test/Lex/output.ml create mode 100644 test/Lex/scan_aux.ml create mode 100644 test/Lex/scanner.mll create mode 100644 test/Lex/syntax.ml create mode 100644 test/Lex/testmain.ml create mode 100644 test/Lex/testscanner.mll create mode 100644 test/Makefile create mode 100644 test/Moretest/.cvsignore create mode 100644 test/Moretest/.depend create mode 100644 test/Moretest/Makefile create mode 100644 test/Moretest/arrays.ml create mode 100644 test/Moretest/bigarrays.ml create mode 100644 test/Moretest/bigarrf.f create mode 100644 test/Moretest/bigarrfml.ml create mode 100644 test/Moretest/bigarrfstub.c create mode 100644 test/Moretest/bigints.ml create mode 100644 test/Moretest/bounds.ml create mode 100644 test/Moretest/boxedints.ml create mode 100644 test/Moretest/callback.ml create mode 100644 test/Moretest/callbackprim.c create mode 100644 test/Moretest/cmcaml.ml create mode 100644 test/Moretest/cmmain.c create mode 100644 test/Moretest/cmstub.c create mode 100644 test/Moretest/equality.ml create mode 100644 test/Moretest/fftba.ml create mode 100644 test/Moretest/float.ml create mode 100644 test/Moretest/globroots.ml create mode 100644 test/Moretest/globrootsprim.c create mode 100644 test/Moretest/graph_example.ml create mode 100644 test/Moretest/graph_test.ml create mode 100644 test/Moretest/includestruct.ml create mode 100644 test/Moretest/intext.ml create mode 100644 test/Moretest/intextaux.c create mode 100644 test/Moretest/io.ml create mode 100644 test/Moretest/manyargs.ml create mode 100644 test/Moretest/manyargsprim.c create mode 100644 test/Moretest/md5.ml create mode 100644 test/Moretest/morematch.ml create mode 100644 test/Moretest/multdef.ml create mode 100644 test/Moretest/multdef.mli create mode 100644 test/Moretest/patmatch.ml create mode 100644 test/Moretest/recvalues.ml create mode 100644 test/Moretest/regexp.ml create mode 100644 test/Moretest/sets.ml create mode 100644 test/Moretest/signals.ml create mode 100644 test/Moretest/stackoverflow.ml create mode 100644 test/Moretest/syserror.ml create mode 100644 test/Moretest/tailcalls.ml create mode 100644 test/Moretest/testrandom.ml create mode 100644 test/Moretest/tscanf.ml create mode 100644 test/Moretest/usemultdef.ml create mode 100644 test/Moretest/warnings.ml create mode 100644 test/Moretest/wc.ml create mode 100644 test/Results/almabench.fast.out create mode 100644 test/Results/almabench.out create mode 100644 test/Results/bdd.out create mode 100644 test/Results/boyer.out create mode 100644 test/Results/fft.fast.runtest create mode 100644 test/Results/fft.runtest create mode 100644 test/Results/fib.out create mode 100644 test/Results/genlex.runtest create mode 100644 test/Results/hamming.out create mode 100644 test/Results/kb.out create mode 100644 test/Results/nucleic.out create mode 100644 test/Results/quicksort.fast.out create mode 100644 test/Results/quicksort.out create mode 100644 test/Results/sieve.out create mode 100644 test/Results/soli.fast.out create mode 100644 test/Results/soli.out create mode 100644 test/Results/sorts.out create mode 100644 test/Results/takc.out create mode 100644 test/Results/taku.out create mode 100644 test/alloc.ml create mode 100644 test/almabench.ml create mode 100644 test/bdd.ml create mode 100644 test/boyer.ml create mode 100644 test/fft.ml create mode 100644 test/fib.ml create mode 100644 test/hamming.ml create mode 100644 test/nucleic.ml create mode 100644 test/ocamldoc/Makefile create mode 100644 test/ocamldoc/t1.ml create mode 100644 test/quicksort.ml create mode 100644 test/sieve.ml create mode 100644 test/soli.ml create mode 100644 test/sorts.ml create mode 100644 test/takc.ml create mode 100644 test/taku.ml create mode 100644 test/testinterp/.cvsignore rename otherlibs/graph/Makefile.Mac => test/testinterp/addbytecode.mpw (51%) create mode 100644 test/testinterp/coverage create mode 100644 test/testinterp/lib.ml create mode 100644 test/testinterp/no68k.rez create mode 100644 test/testinterp/noppc.rez create mode 100644 test/testinterp/runtest.mpw create mode 100644 test/testinterp/t000.ml create mode 100644 test/testinterp/t010-const0.ml create mode 100644 test/testinterp/t010-const1.ml create mode 100644 test/testinterp/t010-const2.ml create mode 100644 test/testinterp/t010-const3.ml create mode 100644 test/testinterp/t011-constint.ml create mode 100644 test/testinterp/t020.ml create mode 100644 test/testinterp/t021-pushconst1.ml create mode 100644 test/testinterp/t021-pushconst2.ml create mode 100644 test/testinterp/t021-pushconst3.ml create mode 100644 test/testinterp/t022-pushconstint.ml create mode 100644 test/testinterp/t040-makeblock1.ml create mode 100644 test/testinterp/t040-makeblock2.ml create mode 100644 test/testinterp/t040-makeblock3.ml create mode 100644 test/testinterp/t041-makeblock.ml create mode 100644 test/testinterp/t050-getglobal.ml create mode 100644 test/testinterp/t050-pushgetglobal.ml create mode 100644 test/testinterp/t051-getglobalfield.ml create mode 100644 test/testinterp/t051-pushgetglobalfield.ml create mode 100644 test/testinterp/t060-raise.ml create mode 100644 test/testinterp/t070-branch.ml create mode 100644 test/testinterp/t070-branchif.ml create mode 100644 test/testinterp/t070-branchifnot.ml create mode 100644 test/testinterp/t071-boolnot.ml create mode 100644 test/testinterp/t080-eq.ml create mode 100644 test/testinterp/t080-geint.ml create mode 100644 test/testinterp/t080-gtint.ml create mode 100644 test/testinterp/t080-leint.ml create mode 100644 test/testinterp/t080-ltint.ml create mode 100644 test/testinterp/t080-neq.ml create mode 100644 test/testinterp/t090-acc0.ml create mode 100644 test/testinterp/t090-acc1.ml create mode 100644 test/testinterp/t090-acc2.ml create mode 100644 test/testinterp/t090-acc3.ml create mode 100644 test/testinterp/t090-acc4.ml create mode 100644 test/testinterp/t090-acc5.ml create mode 100644 test/testinterp/t090-acc6.ml create mode 100644 test/testinterp/t090-acc7.ml create mode 100644 test/testinterp/t091-acc.ml create mode 100644 test/testinterp/t092-pushacc.ml create mode 100644 test/testinterp/t092-pushacc0.ml create mode 100644 test/testinterp/t092-pushacc1.ml create mode 100644 test/testinterp/t092-pushacc2.ml create mode 100644 test/testinterp/t092-pushacc3.ml create mode 100644 test/testinterp/t092-pushacc4.ml create mode 100644 test/testinterp/t092-pushacc5.ml create mode 100644 test/testinterp/t092-pushacc6.ml create mode 100644 test/testinterp/t092-pushacc7.ml create mode 100644 test/testinterp/t093-pushacc.ml create mode 100644 test/testinterp/t100-pushtrap.ml create mode 100644 test/testinterp/t101-poptrap.ml create mode 100644 test/testinterp/t110-addint.ml create mode 100644 test/testinterp/t110-andint.ml create mode 100644 test/testinterp/t110-asrint-1.ml create mode 100644 test/testinterp/t110-asrint-2.ml create mode 100644 test/testinterp/t110-divint-1.ml create mode 100644 test/testinterp/t110-divint-2.ml create mode 100644 test/testinterp/t110-divint-3.ml create mode 100644 test/testinterp/t110-lslint.ml create mode 100644 test/testinterp/t110-lsrint.ml create mode 100644 test/testinterp/t110-modint-1.ml create mode 100644 test/testinterp/t110-modint-2.ml create mode 100644 test/testinterp/t110-mulint.ml create mode 100644 test/testinterp/t110-negint.ml create mode 100644 test/testinterp/t110-offsetint.ml create mode 100644 test/testinterp/t110-orint.ml create mode 100644 test/testinterp/t110-subint.ml create mode 100644 test/testinterp/t110-xorint.ml create mode 100644 test/testinterp/t120-getstringchar.ml create mode 100644 test/testinterp/t121-setstringchar.ml create mode 100644 test/testinterp/t130-getvectitem.ml create mode 100644 test/testinterp/t130-vectlength.ml create mode 100644 test/testinterp/t131-setvectitem.ml create mode 100644 test/testinterp/t140-switch-1.ml create mode 100644 test/testinterp/t140-switch-2.ml create mode 100644 test/testinterp/t140-switch-3.ml create mode 100644 test/testinterp/t140-switch-4.ml create mode 100644 test/testinterp/t141-switch-5.ml create mode 100644 test/testinterp/t141-switch-6.ml create mode 100644 test/testinterp/t141-switch-7.ml create mode 100644 test/testinterp/t142-switch-8.ml create mode 100644 test/testinterp/t142-switch-9.ml create mode 100644 test/testinterp/t142-switch-A.ml create mode 100644 test/testinterp/t150-push-1.ml create mode 100644 test/testinterp/t150-push-2.ml create mode 100644 test/testinterp/t160-closure.ml create mode 100644 test/testinterp/t161-apply1.ml create mode 100644 test/testinterp/t162-return.ml create mode 100644 test/testinterp/t163.ml create mode 100644 test/testinterp/t164-apply2.ml create mode 100644 test/testinterp/t164-apply3.ml create mode 100644 test/testinterp/t165-apply.ml create mode 100644 test/testinterp/t170-envacc2.ml create mode 100644 test/testinterp/t170-envacc3.ml create mode 100644 test/testinterp/t170-envacc4.ml create mode 100644 test/testinterp/t171-envacc.ml create mode 100644 test/testinterp/t172-pushenvacc1.ml create mode 100644 test/testinterp/t172-pushenvacc2.ml create mode 100644 test/testinterp/t172-pushenvacc3.ml create mode 100644 test/testinterp/t172-pushenvacc4.ml create mode 100644 test/testinterp/t173-pushenvacc.ml create mode 100644 test/testinterp/t180-appterm1.ml create mode 100644 test/testinterp/t180-appterm2.ml create mode 100644 test/testinterp/t180-appterm3.ml create mode 100644 test/testinterp/t181-appterm.ml create mode 100644 test/testinterp/t190-makefloatblock-1.ml create mode 100644 test/testinterp/t190-makefloatblock-2.ml create mode 100644 test/testinterp/t190-makefloatblock-3.ml create mode 100644 test/testinterp/t191-vectlength.ml create mode 100644 test/testinterp/t192-getfloatfield-1.ml create mode 100644 test/testinterp/t192-getfloatfield-2.ml create mode 100644 test/testinterp/t193-setfloatfield-1.ml create mode 100644 test/testinterp/t193-setfloatfield-2.ml create mode 100644 test/testinterp/t200-getfield0.ml create mode 100644 test/testinterp/t200-getfield1.ml create mode 100644 test/testinterp/t200-getfield2.ml create mode 100644 test/testinterp/t200-getfield3.ml create mode 100644 test/testinterp/t201-getfield.ml create mode 100644 test/testinterp/t210-setfield0.ml create mode 100644 test/testinterp/t210-setfield1.ml create mode 100644 test/testinterp/t210-setfield2.ml create mode 100644 test/testinterp/t210-setfield3.ml create mode 100644 test/testinterp/t211-setfield.ml create mode 100644 test/testinterp/t220-assign.ml create mode 100644 test/testinterp/t230-check_signals.ml create mode 100644 test/testinterp/t240-c_call1.ml create mode 100644 test/testinterp/t240-c_call2.ml create mode 100644 test/testinterp/t240-c_call3.ml create mode 100644 test/testinterp/t240-c_call4.ml create mode 100644 test/testinterp/t240-c_call5.ml create mode 100644 test/testinterp/t250-closurerec-1.ml create mode 100644 test/testinterp/t250-closurerec-2.ml create mode 100644 test/testinterp/t251-pushoffsetclosure0.ml create mode 100644 test/testinterp/t251-pushoffsetclosure2.ml create mode 100644 test/testinterp/t251-pushoffsetclosurem2.ml create mode 100644 test/testinterp/t252-pushoffsetclosure.ml create mode 100644 test/testinterp/t253-offsetclosure0.ml create mode 100644 test/testinterp/t253-offsetclosure2.ml create mode 100644 test/testinterp/t253-offsetclosurem2.ml create mode 100644 test/testinterp/t254-offsetclosure.ml create mode 100644 test/testinterp/t260-offsetref.ml create mode 100644 test/testinterp/t270-push_retaddr.ml create mode 100644 test/testinterp/t300-getmethod.ml create mode 100644 test/testinterp/t301-object.ml create mode 100644 test/testinterp/t310-alloc-1.ml create mode 100644 test/testinterp/t310-alloc-2.ml create mode 100644 test/testinterp/t320-gc-1.ml create mode 100644 test/testinterp/t320-gc-2.ml create mode 100644 test/testinterp/t320-gc-3.ml create mode 100644 test/testinterp/t330-compact-1.ml create mode 100644 test/testinterp/t330-compact-2.ml create mode 100644 test/testinterp/t330-compact-3.ml create mode 100644 test/testinterp/t330-compact-4.ml create mode 100644 test/testinterp/t340-weak.ml create mode 100644 test/testinterp/t350-heapcheck.ml create mode 100644 test/testinterp/t360-stacks-1.ml create mode 100644 test/testinterp/t360-stacks-2.ml create mode 100644 testasmcomp/.cvsignore create mode 100644 testasmcomp/.depend create mode 100644 testasmcomp/Makefile create mode 100644 testasmcomp/alpha.S create mode 100644 testasmcomp/amd64.S create mode 100644 testasmcomp/arith.cmm create mode 100644 testasmcomp/arm.S create mode 100644 testasmcomp/checkbound.cmm create mode 100644 testasmcomp/fib.cmm create mode 100644 testasmcomp/hppa.S create mode 100644 testasmcomp/i386.S create mode 100644 testasmcomp/i386nt.asm create mode 100644 testasmcomp/ia64.S create mode 100644 testasmcomp/integr.cmm create mode 100644 testasmcomp/lexcmm.mli create mode 100644 testasmcomp/lexcmm.mll create mode 100644 testasmcomp/m68k.S create mode 100644 testasmcomp/main.c create mode 100644 testasmcomp/main.ml create mode 100644 testasmcomp/mainarith.c create mode 100644 testasmcomp/mips.s create mode 100644 testasmcomp/parsecmm.mly create mode 100644 testasmcomp/parsecmmaux.ml create mode 100644 testasmcomp/parsecmmaux.mli create mode 100644 testasmcomp/power-aix.S create mode 100644 testasmcomp/power-elf.S create mode 100644 testasmcomp/power-rhapsody.S create mode 100644 testasmcomp/quicksort.cmm create mode 100644 testasmcomp/quicksort2.cmm create mode 100644 testasmcomp/soli.cmm create mode 100644 testasmcomp/sparc.S create mode 100644 testasmcomp/tagged-fib.cmm create mode 100644 testasmcomp/tagged-integr.cmm create mode 100644 testasmcomp/tagged-quicksort.cmm create mode 100644 testasmcomp/tagged-tak.cmm create mode 100644 testasmcomp/tak.cmm create mode 100644 testlabl/.cvsignore create mode 100644 testlabl/Makefile create mode 100644 testlabl/bugs/yamagata021012.ml create mode 100644 testlabl/dirs_multimatch create mode 100644 testlabl/dirs_poly create mode 100644 testlabl/mixin.ml create mode 100644 testlabl/mixin2.ml create mode 100644 testlabl/mixin3.ml create mode 100644 testlabl/multimatch.ml create mode 100644 testlabl/newlabels.ps create mode 100644 testlabl/objvariant.ml create mode 100644 testlabl/poly.exp create mode 100644 testlabl/poly.exp2 create mode 100644 testlabl/poly.ml create mode 100644 testlabl/printers.ml create mode 100644 testlabl/tests.ml create mode 100644 testobjects/.cvsignore create mode 100644 testobjects/Exemples.exp create mode 100644 testobjects/Exemples.ml create mode 100644 testobjects/Makefile create mode 100644 testobjects/Tests.exp create mode 100644 testobjects/Tests.ml delete mode 100644 tools/Makefile.Mac delete mode 100644 tools/Makefile.Mac.depend delete mode 100644 tools/make-opcodes.Mac create mode 100644 win32caml/editbuffer.c create mode 100644 win32caml/editbuffer.h create mode 100644 win32caml/history.c create mode 100644 win32caml/history.h create mode 100644 win32caml/resource.h delete mode 100644 yacc/Makefile.Mac diff --git a/.depend b/.depend index bf99d6fa..b6af556a 100644 --- a/.depend +++ b/.depend @@ -139,9 +139,11 @@ typing/includemod.cmx: typing/ctype.cmx typing/env.cmx typing/ident.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/ident.cmi typing/path.cmi typing/subst.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/ident.cmx typing/path.cmx typing/subst.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 \ @@ -184,7 +186,7 @@ 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/predef.cmi typing/printtyp.cmi typing/stypes.cmi typing/subst.cmi \ typing/typecore.cmi typing/typedecl.cmi typing/typedtree.cmi \ typing/types.cmi typing/typetexp.cmi utils/warnings.cmi \ typing/typeclass.cmi @@ -192,7 +194,7 @@ 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/predef.cmx typing/printtyp.cmx typing/stypes.cmx typing/subst.cmx \ typing/typecore.cmx typing/typedecl.cmx typing/typedtree.cmx \ typing/types.cmx typing/typetexp.cmx utils/warnings.cmx \ typing/typeclass.cmi @@ -265,8 +267,8 @@ bytecomp/instruct.cmi: typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \ typing/types.cmi bytecomp/lambda.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \ typing/path.cmi typing/primitive.cmi typing/types.cmi -bytecomp/matching.cmi: typing/ident.cmi bytecomp/lambda.cmi \ - parsing/location.cmi typing/typedtree.cmi +bytecomp/matching.cmi: parsing/asttypes.cmi typing/ident.cmi \ + bytecomp/lambda.cmi parsing/location.cmi typing/typedtree.cmi bytecomp/printinstr.cmi: bytecomp/instruct.cmi bytecomp/printlambda.cmi: bytecomp/lambda.cmi bytecomp/simplif.cmi: bytecomp/lambda.cmi @@ -278,7 +280,7 @@ bytecomp/translcore.cmi: parsing/asttypes.cmi typing/ident.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/translobj.cmi: typing/env.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 \ @@ -375,16 +377,18 @@ bytecomp/symtable.cmx: parsing/asttypes.cmi bytecomp/bytesections.cmx \ utils/clflags.cmx bytecomp/dll.cmx bytecomp/emitcode.cmx typing/ident.cmx \ bytecomp/lambda.cmx bytecomp/meta.cmx utils/misc.cmx typing/predef.cmx \ bytecomp/runtimedef.cmx utils/tbl.cmx bytecomp/symtable.cmi -bytecomp/translclass.cmo: parsing/asttypes.cmi utils/clflags.cmo \ - typing/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/translclass.cmo: parsing/asttypes.cmi typing/btype.cmi \ + utils/clflags.cmo typing/ctype.cmi typing/env.cmi typing/ident.cmi \ + bytecomp/lambda.cmi parsing/location.cmi bytecomp/matching.cmi \ + utils/misc.cmi typing/path.cmi bytecomp/translcore.cmi \ + bytecomp/translobj.cmi typing/typeclass.cmi typing/typedtree.cmi \ + bytecomp/typeopt.cmi typing/types.cmi bytecomp/translclass.cmi +bytecomp/translclass.cmx: parsing/asttypes.cmi typing/btype.cmx \ + utils/clflags.cmx typing/ctype.cmx typing/env.cmx typing/ident.cmx \ + bytecomp/lambda.cmx parsing/location.cmx bytecomp/matching.cmx \ + utils/misc.cmx typing/path.cmx bytecomp/translcore.cmx \ + bytecomp/translobj.cmx typing/typeclass.cmx typing/typedtree.cmx \ + bytecomp/typeopt.cmx typing/types.cmx bytecomp/translclass.cmi bytecomp/translcore.cmo: parsing/asttypes.cmi typing/btype.cmi \ utils/clflags.cmo utils/config.cmi typing/env.cmi typing/ident.cmi \ bytecomp/lambda.cmi parsing/location.cmi bytecomp/matching.cmi \ @@ -409,11 +413,13 @@ bytecomp/translmod.cmx: parsing/asttypes.cmi utils/config.cmx \ typing/predef.cmx typing/primitive.cmx typing/printtyp.cmx \ bytecomp/translclass.cmx bytecomp/translcore.cmx bytecomp/translobj.cmx \ typing/typedtree.cmx typing/types.cmx bytecomp/translmod.cmi -bytecomp/translobj.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \ - bytecomp/lambda.cmi parsing/longident.cmi utils/misc.cmi \ +bytecomp/translobj.cmo: parsing/asttypes.cmi typing/btype.cmi \ + utils/clflags.cmo typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \ + parsing/longident.cmi utils/misc.cmi typing/primitive.cmi \ bytecomp/translobj.cmi -bytecomp/translobj.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \ - bytecomp/lambda.cmx parsing/longident.cmx utils/misc.cmx \ +bytecomp/translobj.cmx: parsing/asttypes.cmi typing/btype.cmx \ + utils/clflags.cmx typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx \ + parsing/longident.cmx utils/misc.cmx typing/primitive.cmx \ bytecomp/translobj.cmi bytecomp/typeopt.cmo: parsing/asttypes.cmi typing/ctype.cmi typing/env.cmi \ typing/ident.cmi bytecomp/lambda.cmi utils/misc.cmi typing/path.cmi \ @@ -452,8 +458,8 @@ asmcomp/selectgen.cmi: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \ asmcomp/selection.cmi: asmcomp/cmm.cmi asmcomp/mach.cmi asmcomp/spill.cmi: asmcomp/mach.cmi asmcomp/split.cmi: asmcomp/mach.cmi -asmcomp/arch.cmo: utils/config.cmi utils/misc.cmi -asmcomp/arch.cmx: utils/config.cmx utils/misc.cmx +asmcomp/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 \ diff --git a/Changes b/Changes index b0cb25c6..1d26ffcb 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,105 @@ +Objective Caml 3.08: +-------------------- + +(Changes that can break existing programs are marked with a "*" ) + +Language features: +- Support for immediate objects, i.e. objects defined without going + through a class. (Syntax is "object end".) + +Type-checking: +- When typing record construction and record patterns, can omit + the module qualification on all labels except one. I.e. + { M.l1 = ...; l2 = ... } is interpreted as { M.l1 = ...; M.l2 = ... } + +Both compilers: +- More compact compilation of classes. +- Much more efficient handling of class definitions inside functors + or local modules. +- Simpler representation for method tables. Objects can now be marshaled + between identical programs with the flag Marshal.Closures. +- Improved error messages for objects and variants. +- Improved printing of inferred module signatures (toplevel and ocamlc -i). + Recursion between type, class, class type and module definitions is now + correctly printed. +- The -pack option now accepts compiled interfaces (.cmi files) in addition + to compiled implementations (.cmo or .cmx). +* A compile-time error is signaled if an integer literal exceeds the + range of representable integers. +- Fixed code generation error for "module rec" definitions. +- The combination of options -c -o sets the name of the generated + .cmi / .cmo / .cmx files. + +Bytecode compiler: +- Option -output-obj is now compatible with Dynlink and + with embedded toplevels. + +Native-code compiler: +- Division and modulus by zero correctly raise exception Division_by_zero + (instead of causing a hardware trap). +- Improved compilation time for the register allocation phase. +- The float constant -0.0 was incorrectly treated as +0.0 on some processors. +- AMD64: fixed bugs in asm glue code for GC invocation and exception raising + from C. +- IA64: fixed incorrect code generated for "expr mod 1". +- PowerPC: minor performance tweaks for the G4 and G5 processors. + +Standard library: +* Revised handling of NaN floats in polymorphic comparisons. + The polymorphic boolean-valued comparisons (=, <, >, etc) now treat + NaN as uncomparable, as specified by the IEEE standard. + The 3-valued comparison (compare) treats NaN as equal to itself + and smaller than all other floats. As a consequence, x == y + no longer implies x = y but still implies compare x y = 0. +* String-to-integer conversions now fail if the result overflows + the range of integers representable in the result type. +* All array and string access functions now raise + Invalid_argument("index out of bounds") when a bounds check fails. + In earlier releases, different exceptions were raised + in bytecode and native-code. +- Module Buffer: new functions Buffer.sub, Buffer.nth +- Module Int32: new functions Int32.bits_of_float, Int32.float_of_bits. +- Module Map: new functions is_empty, compare, equal. +- Module Set: new function split. +* Module Gc: in-order finalisation, new function finalise_release. + +Other libraries: +- The Num library: complete reimplementation of the C/asm lowest + layer to work around potential licensing problems. + Improved speed on the PowerPC and AMD64 architectures. +- The Graphics library: improved event handling under MS Windows. +- The Str library: fixed bug in "split" functions with nullable regexps. +- The Unix library: + . Added Unix.single_write. + . Added support for IPv6. + . Bug fixes in Unix.closedir. + . Allow thread switching on Unix.lockf. + +Runtime System: +* Name space depollution: all global C identifiers are now prefixed + with "caml" to avoid name clashes with other libraries. This + includes the "external" primitives of the standard runtime. + +Ports: +- Windows ports: many improvements in the OCamlWin toplevel application + (history, save inputs to file, etc). Contributed by Christopher A. Watford. +- Native-code compilation supported for HPPA/Linux. Contributed by Guy Martin. +- Removed support for MacOS9. Mac OS 9 is obsolete and the port was not + updated since 3.05. +- Removed ocamlopt support for HPPA/Nextstep and Power/AIX. + +Ocamllex: +- #line directives in the input file are now accepted. +- Added character set concatenation operator "cset1 # cset2". + +Ocamlyacc: +- #line directives in the input file are now accepted. + +Camlp4: +* Support for new-style locations (line numbers, not just character numbers). +- See camlp4/CHANGES and camlp4/ICHANGES for more info. + + Objective Caml 3.07: -------------------- @@ -30,7 +132,7 @@ Type-checking: type of any subexpression in the source file. Works even in the case of a type error (all the types computed up to the error are available). This new feature is also supported by ocamlbrowser. -- Disable "method is overriden" warning when the method was explicitely +- Disable "method is overriden" warning when the method was explicitly redefined as virtual beforehand (i.e. not through inheritance). Typing and semantics are unchanged. @@ -1655,3 +1757,5 @@ Caml Special Light 1.06: ------------------------ * First public release. + +$Id: Changes,v 1.140.2.3 2004/07/05 07:24:00 xleroy Exp $ diff --git a/INSTALL b/INSTALL index 2fc5a302..d57573e4 100644 --- a/INSTALL +++ b/INSTALL @@ -11,7 +11,7 @@ PREREQUISITES are all *required*. The vendor-provided compiler, assembler and make have major problems. -* Under MacOS X, before you begin, you must raise the limit on the +* Under MacOS X up to version 10.2.8, you must raise the limit on the stack size with one of the following commands: limit stacksize 64M # if your shell is zsh or tcsh @@ -84,6 +84,23 @@ The "configure" script accepts the following options: -no-pthread Do not attempt to use POSIX threads. +-with-pthread + Attempt to use POSIX threads (this is the default). + +-no-shared-libs + Do not configure support for shared libraries + +-dldefs +-dllibs + These options specify where to find the libraries for dynamic + linking (i.e. use of shared libraries). "-dldefs" specifies + options for finding the header files, and "-dllibs" for finding + the C libraries. + +-binutils + This option specifies where to find the GNU binutils (objcopy + and nm) executables. + -verbose Verbose output of the configuration tests. Use it if the outcome of configure is not what you were expecting. @@ -245,10 +262,14 @@ COMMON PROBLEMS: * The Makefiles use the "include" directive, which is not supported by all versions of make. Use GNU make if this is a problem. -* The Makefiles assume that make execute commands by calling /bin/sh. They +* The Makefiles assume that make executes commands by calling /bin/sh. They won't work if /bin/csh is called instead. You may have to unset the SHELL environment variable, or set it to /bin/sh. +* On some systems, localization causes build problems. You should +try to set the C locale (export LC_ALL=C) before compiling if you have +strange errors while compiling OCaml. + * gcc 2.7.2.1 generates incorrect code for the runtime system in -O mode on some Intel x86 platforms (e.g. Linux RedHat 4.1 and 4.2). If this causes a problem, the solution is to upgrade to 2.7.2.3 or above. diff --git a/INSTALL.MPW b/INSTALL.MPW deleted file mode 100644 index 67afcd2e..00000000 --- a/INSTALL.MPW +++ /dev/null @@ -1,89 +0,0 @@ -# $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/Makefile b/Makefile index 1a974109..7a368ecb 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.184 2003/07/03 15:13:21 xleroy Exp $ +# $Id: Makefile,v 1.186.2.3 2004/07/02 12:19:18 mauny Exp $ # The main Makefile @@ -107,7 +107,7 @@ 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 + bytecomp/dll.cmo bytecomp/meta.cmo bytecomp/symtable.cmo toplevel/expunge.cmo PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop @@ -627,7 +627,9 @@ checkstack: # Make MacOS X package -package-macosx: FORCE +.PHONY: package-macosx + +package-macosx: make BINDIR="`pwd`"/package-macosx/root$(BINDIR) \ LIBDIR="`pwd`"/package-macosx/root$(LIBDIR) \ MANDIR="`pwd`"/package-macosx/root$(MANDIR) install diff --git a/Makefile.Mac b/Makefile.Mac deleted file mode 100644 index a7215869..00000000 --- a/Makefile.Mac +++ /dev/null @@ -1,488 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id: 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 deleted file mode 100644 index ecc9ddd1..00000000 --- a/Makefile.Mac.depend +++ /dev/null @@ -1,548 +0,0 @@ -:bytecomp:dll.cmo Ä :bytecomp:dll.cmi -:utils:ccomp.cmoÄ :utils:clflags.cmo :utils:config.cmi :utils:misc.cmi ¶ - :utils:ccomp.cmi -:utils:ccomp.cmxÄ :utils:clflags.cmx :utils:config.cmx :utils:misc.cmx ¶ - :utils:ccomp.cmi -:utils:clflags.cmoÄ :utils:config.cmi -:utils:clflags.cmxÄ :utils:config.cmx -:utils:config.cmoÄ :utils:config.cmi -:utils:config.cmxÄ :utils:config.cmi -:utils:misc.cmoÄ :utils:misc.cmi -:utils:misc.cmxÄ :utils:misc.cmi -:utils:tbl.cmoÄ :utils:tbl.cmi -:utils:tbl.cmxÄ :utils:tbl.cmi -:utils:terminfo.cmoÄ :utils:terminfo.cmi -:utils:terminfo.cmxÄ :utils:terminfo.cmi -:utils:warnings.cmoÄ :utils:warnings.cmi -:utils:warnings.cmxÄ :utils:warnings.cmi -:parsing:lexer.cmiÄ :parsing:parser.cmi -:parsing:location.cmiÄ :utils:warnings.cmi -:parsing:parse.cmiÄ :parsing:parsetree.cmi -:parsing:parser.cmiÄ :parsing:parsetree.cmi -:parsing:parsetree.cmiÄ :parsing:asttypes.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi -:parsing:printast.cmiÄ :parsing:parsetree.cmi -:parsing:pstream.cmiÄ :parsing:parsetree.cmi -:parsing:syntaxerr.cmiÄ :parsing:location.cmi -:parsing:lexer.cmoÄ :parsing:location.cmi :utils:misc.cmi :parsing:parser.cmi ¶ - :utils:warnings.cmi :parsing:lexer.cmi -:parsing:lexer.cmxÄ :parsing:location.cmx :utils:misc.cmx :parsing:parser.cmx ¶ - :utils:warnings.cmx :parsing:lexer.cmi -:parsing:linenum.cmoÄ :utils:misc.cmi :parsing:linenum.cmi -:parsing:linenum.cmxÄ :utils:misc.cmx :parsing:linenum.cmi -:parsing:location.cmoÄ :parsing:linenum.cmi :utils:terminfo.cmi ¶ - :utils:warnings.cmi :parsing:location.cmi -:parsing:location.cmxÄ :parsing:linenum.cmx :utils:terminfo.cmx ¶ - :utils:warnings.cmx :parsing:location.cmi -:parsing:longident.cmoÄ :utils:misc.cmi :parsing:longident.cmi -:parsing:longident.cmxÄ :utils:misc.cmx :parsing:longident.cmi -:parsing:parse.cmoÄ :parsing:lexer.cmi :parsing:location.cmi ¶ - :parsing:parser.cmi :parsing:syntaxerr.cmi :parsing:parse.cmi -:parsing:parse.cmxÄ :parsing:lexer.cmx :parsing:location.cmx ¶ - :parsing:parser.cmx :parsing:syntaxerr.cmx :parsing:parse.cmi -:parsing:parser.cmoÄ :parsing:asttypes.cmi :utils:clflags.cmo ¶ - :parsing:location.cmi :parsing:longident.cmi :parsing:parsetree.cmi ¶ - :parsing:pstream.cmi :parsing:syntaxerr.cmi :parsing:parser.cmi -:parsing:parser.cmxÄ :parsing:asttypes.cmi :utils:clflags.cmx ¶ - :parsing:location.cmx :parsing:longident.cmx :parsing:parsetree.cmi ¶ - :parsing:pstream.cmx :parsing:syntaxerr.cmx :parsing:parser.cmi -:parsing:printast.cmoÄ :parsing:asttypes.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :parsing:parsetree.cmi :parsing:printast.cmi -:parsing:printast.cmxÄ :parsing:asttypes.cmi :parsing:location.cmx ¶ - :parsing:longident.cmx :parsing:parsetree.cmi :parsing:printast.cmi -:parsing:pstream.cmoÄ :parsing:asttypes.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :parsing:parsetree.cmi :parsing:pstream.cmi -:parsing:pstream.cmxÄ :parsing:asttypes.cmi :parsing:location.cmx ¶ - :parsing:longident.cmx :parsing:parsetree.cmi :parsing:pstream.cmi -:parsing:syntaxerr.cmoÄ :parsing:location.cmi :parsing:syntaxerr.cmi -:parsing:syntaxerr.cmxÄ :parsing:location.cmx :parsing:syntaxerr.cmi -:typing:btype.cmiÄ :parsing:asttypes.cmi :typing:path.cmi :typing:types.cmi -:typing:ctype.cmiÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶ - :typing:path.cmi :typing:types.cmi -:typing:datarepr.cmiÄ :parsing:asttypes.cmi :typing:path.cmi ¶ - :typing:types.cmi -:typing:env.cmiÄ :typing:ident.cmi :parsing:longident.cmi :typing:path.cmi ¶ - :typing:types.cmi -:typing:includeclass.cmiÄ :typing:ctype.cmi :typing:env.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:includecore.cmiÄ :typing:env.cmi :typing:ident.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:includemod.cmiÄ :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:mtype.cmiÄ :typing:env.cmi :typing:ident.cmi :typing:path.cmi ¶ - :typing:types.cmi -:typing:parmatch.cmiÄ :typing:env.cmi :parsing:location.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:path.cmiÄ :typing:ident.cmi -:typing:predef.cmiÄ :typing:ident.cmi :typing:path.cmi :typing:types.cmi -:typing:printtyp.cmiÄ :typing:ident.cmi :parsing:longident.cmi ¶ - :typing:outcometree.cmi :typing:path.cmi :typing:types.cmi -:typing:subst.cmiÄ :typing:ident.cmi :typing:path.cmi :typing:types.cmi -:typing:typeclass.cmiÄ :parsing:asttypes.cmi :typing:ctype.cmi ¶ - :typing:env.cmi :typing:ident.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :parsing:parsetree.cmi :typing:typedtree.cmi ¶ - :typing:types.cmi -:typing:typecore.cmiÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶ - :parsing:location.cmi :parsing:longident.cmi :parsing:parsetree.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:typedecl.cmiÄ :typing:env.cmi :typing:ident.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :parsing:parsetree.cmi :typing:path.cmi ¶ - :typing:types.cmi -:typing:typedtree.cmiÄ :parsing:asttypes.cmi :typing:env.cmi ¶ - :typing:ident.cmi :parsing:location.cmi :typing:path.cmi ¶ - :typing:primitive.cmi :typing:types.cmi -:typing:typemod.cmiÄ :typing:env.cmi :typing:ident.cmi :typing:includemod.cmi ¶ - :parsing:location.cmi :parsing:longident.cmi :parsing:parsetree.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi -:typing:types.cmiÄ :parsing:asttypes.cmi :typing:ident.cmi :typing:path.cmi ¶ - :typing:primitive.cmi -:typing:typetexp.cmiÄ :typing:env.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :parsing:parsetree.cmi :typing:types.cmi -:typing:btype.cmoÄ :utils:misc.cmi :typing:path.cmi :typing:types.cmi ¶ - :typing:btype.cmi -:typing:btype.cmxÄ :utils:misc.cmx :typing:path.cmx :typing:types.cmx ¶ - :typing:btype.cmi -:typing:ctype.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi :utils:clflags.cmo ¶ - :typing:env.cmi :typing:ident.cmi :parsing:longident.cmi :utils:misc.cmi ¶ - :typing:path.cmi :typing:subst.cmi :typing:types.cmi :typing:ctype.cmi -:typing:ctype.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx :utils:clflags.cmx ¶ - :typing:env.cmx :typing:ident.cmx :parsing:longident.cmx :utils:misc.cmx ¶ - :typing:path.cmx :typing:subst.cmx :typing:types.cmx :typing:ctype.cmi -:typing:datarepr.cmoÄ :parsing:asttypes.cmi :utils:misc.cmi ¶ - :typing:predef.cmi :typing:types.cmi :typing:datarepr.cmi -:typing:datarepr.cmxÄ :parsing:asttypes.cmi :utils:misc.cmx ¶ - :typing:predef.cmx :typing:types.cmx :typing:datarepr.cmi -:typing:env.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi :utils:config.cmi ¶ - :typing:datarepr.cmi :typing:ident.cmi :parsing:longident.cmi ¶ - :utils:misc.cmi :typing:path.cmi :typing:predef.cmi :typing:subst.cmi ¶ - :utils:tbl.cmi :typing:types.cmi :typing:env.cmi -:typing:env.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx :utils:config.cmx ¶ - :typing:datarepr.cmx :typing:ident.cmx :parsing:longident.cmx ¶ - :utils:misc.cmx :typing:path.cmx :typing:predef.cmx :typing:subst.cmx ¶ - :utils:tbl.cmx :typing:types.cmx :typing:env.cmi -:typing:ident.cmoÄ :typing:ident.cmi -:typing:ident.cmxÄ :typing:ident.cmi -:typing:includeclass.cmoÄ :typing:ctype.cmi :typing:printtyp.cmi ¶ - :typing:types.cmi :typing:includeclass.cmi -:typing:includeclass.cmxÄ :typing:ctype.cmx :typing:printtyp.cmx ¶ - :typing:types.cmx :typing:includeclass.cmi -:typing:includecore.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :typing:ctype.cmi :utils:misc.cmi :typing:path.cmi :typing:predef.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi :typing:includecore.cmi -:typing:includecore.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :typing:ctype.cmx :utils:misc.cmx :typing:path.cmx :typing:predef.cmx ¶ - :typing:typedtree.cmx :typing:types.cmx :typing:includecore.cmi -:typing:includemod.cmoÄ :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶ - :typing:includeclass.cmi :typing:includecore.cmi :utils:misc.cmi ¶ - :typing:mtype.cmi :typing:path.cmi :typing:printtyp.cmi :typing:subst.cmi ¶ - :utils:tbl.cmi :typing:typedtree.cmi :typing:types.cmi ¶ - :typing:includemod.cmi -:typing:includemod.cmxÄ :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶ - :typing:includeclass.cmx :typing:includecore.cmx :utils:misc.cmx ¶ - :typing:mtype.cmx :typing:path.cmx :typing:printtyp.cmx :typing:subst.cmx ¶ - :utils:tbl.cmx :typing:typedtree.cmx :typing:types.cmx ¶ - :typing:includemod.cmi -:typing:mtype.cmoÄ :typing:btype.cmi :typing:ctype.cmi :typing:env.cmi ¶ - :typing:ident.cmi :typing:path.cmi :typing:types.cmi :typing:mtype.cmi -:typing:mtype.cmxÄ :typing:btype.cmx :typing:ctype.cmx :typing:env.cmx ¶ - :typing:ident.cmx :typing:path.cmx :typing:types.cmx :typing:mtype.cmi -:typing:parmatch.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :typing:ctype.cmi :typing:datarepr.cmi :typing:env.cmi :typing:ident.cmi ¶ - :parsing:location.cmi :utils:misc.cmi :typing:path.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi :utils:warnings.cmi ¶ - :typing:parmatch.cmi -:typing:parmatch.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :typing:ctype.cmx :typing:datarepr.cmx :typing:env.cmx :typing:ident.cmx ¶ - :parsing:location.cmx :utils:misc.cmx :typing:path.cmx ¶ - :typing:typedtree.cmx :typing:types.cmx :utils:warnings.cmx ¶ - :typing:parmatch.cmi -:typing:path.cmoÄ :typing:ident.cmi :typing:path.cmi -:typing:path.cmxÄ :typing:ident.cmx :typing:path.cmi -:typing:predef.cmoÄ :typing:btype.cmi :typing:ident.cmi :typing:path.cmi ¶ - :typing:types.cmi :typing:predef.cmi -:typing:predef.cmxÄ :typing:btype.cmx :typing:ident.cmx :typing:path.cmx ¶ - :typing:types.cmx :typing:predef.cmi -:typing:primitive.cmoÄ :utils:misc.cmi :typing:primitive.cmi -:typing:primitive.cmxÄ :utils:misc.cmx :typing:primitive.cmi -:typing:printtyp.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶ - :parsing:longident.cmi :utils:misc.cmi :typing:outcometree.cmi ¶ - :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶ - :typing:types.cmi :typing:printtyp.cmi -:typing:printtyp.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶ - :parsing:longident.cmx :utils:misc.cmx :typing:outcometree.cmi ¶ - :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶ - :typing:types.cmx :typing:printtyp.cmi -:typing:subst.cmoÄ :typing:btype.cmi :typing:ident.cmi :utils:misc.cmi ¶ - :typing:path.cmi :utils:tbl.cmi :typing:types.cmi :typing:subst.cmi -:typing:subst.cmxÄ :typing:btype.cmx :typing:ident.cmx :utils:misc.cmx ¶ - :typing:path.cmx :utils:tbl.cmx :typing:types.cmx :typing:subst.cmi -:typing:typeclass.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶ - :typing:includeclass.cmi :parsing:location.cmi :parsing:longident.cmi ¶ - :utils:misc.cmi :typing:parmatch.cmi :parsing:parsetree.cmi ¶ - :typing:path.cmi :typing:predef.cmi :typing:printtyp.cmi ¶ - :typing:typecore.cmi :typing:typedecl.cmi :typing:typedtree.cmi ¶ - :typing:types.cmi :typing:typetexp.cmi :utils:warnings.cmi ¶ - :typing:typeclass.cmi -:typing:typeclass.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶ - :typing:includeclass.cmx :parsing:location.cmx :parsing:longident.cmx ¶ - :utils:misc.cmx :typing:parmatch.cmx :parsing:parsetree.cmi ¶ - :typing:path.cmx :typing:predef.cmx :typing:printtyp.cmx ¶ - :typing:typecore.cmx :typing:typedecl.cmx :typing:typedtree.cmx ¶ - :typing:types.cmx :typing:typetexp.cmx :utils:warnings.cmx ¶ - :typing:typeclass.cmi -:typing:typecore.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :typing:ctype.cmi :typing:env.cmi :typing:ident.cmi ¶ - :parsing:location.cmi :parsing:longident.cmi :utils:misc.cmi ¶ - :typing:parmatch.cmi :parsing:parsetree.cmi :typing:path.cmi ¶ - :typing:predef.cmi :typing:primitive.cmi :typing:printtyp.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi :typing:typetexp.cmi ¶ - :utils:warnings.cmi :typing:typecore.cmi -:typing:typecore.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :typing:ctype.cmx :typing:env.cmx :typing:ident.cmx ¶ - :parsing:location.cmx :parsing:longident.cmx :utils:misc.cmx ¶ - :typing:parmatch.cmx :parsing:parsetree.cmi :typing:path.cmx ¶ - :typing:predef.cmx :typing:primitive.cmx :typing:printtyp.cmx ¶ - :typing:typedtree.cmx :typing:types.cmx :typing:typetexp.cmx ¶ - :utils:warnings.cmx :typing:typecore.cmi -:typing:typedecl.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :utils:config.cmi :typing:ctype.cmi :typing:env.cmi ¶ - :typing:ident.cmi :typing:includecore.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :utils:misc.cmi :parsing:parsetree.cmi ¶ - :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶ - :typing:printtyp.cmi :typing:subst.cmi :typing:typedtree.cmi ¶ - :typing:types.cmi :typing:typetexp.cmi :typing:typedecl.cmi -:typing:typedecl.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :utils:config.cmx :typing:ctype.cmx :typing:env.cmx ¶ - :typing:ident.cmx :typing:includecore.cmx :parsing:location.cmx ¶ - :parsing:longident.cmx :utils:misc.cmx :parsing:parsetree.cmi ¶ - :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶ - :typing:printtyp.cmx :typing:subst.cmx :typing:typedtree.cmx ¶ - :typing:types.cmx :typing:typetexp.cmx :typing:typedecl.cmi -:typing:typedtree.cmoÄ :parsing:asttypes.cmi :typing:env.cmi ¶ - :typing:ident.cmi :parsing:location.cmi :utils:misc.cmi :typing:path.cmi ¶ - :typing:primitive.cmi :typing:types.cmi :typing:typedtree.cmi -:typing:typedtree.cmxÄ :parsing:asttypes.cmi :typing:env.cmx ¶ - :typing:ident.cmx :parsing:location.cmx :utils:misc.cmx :typing:path.cmx ¶ - :typing:primitive.cmx :typing:types.cmx :typing:typedtree.cmi -:typing:typemod.cmoÄ :utils:clflags.cmo :utils:config.cmi :typing:ctype.cmi ¶ - :typing:env.cmi :typing:ident.cmi :typing:includemod.cmi ¶ - :parsing:location.cmi :parsing:longident.cmi :utils:misc.cmi ¶ - :typing:mtype.cmi :parsing:parsetree.cmi :typing:path.cmi ¶ - :typing:printtyp.cmi :typing:subst.cmi :typing:typeclass.cmi ¶ - :typing:typecore.cmi :typing:typedecl.cmi :typing:typedtree.cmi ¶ - :typing:types.cmi :typing:typemod.cmi -:typing:typemod.cmxÄ :utils:clflags.cmx :utils:config.cmx :typing:ctype.cmx ¶ - :typing:env.cmx :typing:ident.cmx :typing:includemod.cmx ¶ - :parsing:location.cmx :parsing:longident.cmx :utils:misc.cmx ¶ - :typing:mtype.cmx :parsing:parsetree.cmi :typing:path.cmx ¶ - :typing:printtyp.cmx :typing:subst.cmx :typing:typeclass.cmx ¶ - :typing:typecore.cmx :typing:typedecl.cmx :typing:typedtree.cmx ¶ - :typing:types.cmx :typing:typemod.cmi -:typing:types.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi :utils:misc.cmi ¶ - :typing:path.cmi :typing:primitive.cmi :typing:types.cmi -:typing:types.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx :utils:misc.cmx ¶ - :typing:path.cmx :typing:primitive.cmx :typing:types.cmi -:typing:typetexp.cmoÄ :typing:btype.cmi :typing:ctype.cmi :typing:env.cmi ¶ - :parsing:location.cmi :parsing:longident.cmi :utils:misc.cmi ¶ - :parsing:parsetree.cmi :typing:printtyp.cmi :utils:tbl.cmi ¶ - :typing:types.cmi :typing:typetexp.cmi -:typing:typetexp.cmxÄ :typing:btype.cmx :typing:ctype.cmx :typing:env.cmx ¶ - :parsing:location.cmx :parsing:longident.cmx :utils:misc.cmx ¶ - :parsing:parsetree.cmi :typing:printtyp.cmx :utils:tbl.cmx ¶ - :typing:types.cmx :typing:typetexp.cmi -:bytecomp:bytegen.cmiÄ :bytecomp:instruct.cmi :bytecomp:lambda.cmi -:bytecomp:bytelink.cmiÄ :bytecomp:emitcode.cmi :bytecomp:symtable.cmi -:bytecomp:emitcode.cmiÄ :typing:ident.cmi :bytecomp:instruct.cmi ¶ - :bytecomp:lambda.cmi -:bytecomp:instruct.cmiÄ :typing:env.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :typing:types.cmi -:bytecomp:lambda.cmiÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶ - :typing:path.cmi :typing:primitive.cmi :typing:types.cmi -:bytecomp:matching.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi ¶ - :parsing:location.cmi :typing:typedtree.cmi -:bytecomp:printinstr.cmiÄ :bytecomp:instruct.cmi -:bytecomp:printlambda.cmiÄ :bytecomp:lambda.cmi -:bytecomp:simplif.cmiÄ :bytecomp:lambda.cmi -:bytecomp:symtable.cmiÄ :bytecomp:emitcode.cmi :typing:ident.cmi -:bytecomp:translclass.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi ¶ - :parsing:location.cmi :typing:typedtree.cmi -:bytecomp:translcore.cmiÄ :parsing:asttypes.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :parsing:location.cmi :typing:path.cmi ¶ - :typing:primitive.cmi :typing:typedtree.cmi :typing:types.cmi -:bytecomp:translmod.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi ¶ - :typing:typedtree.cmi -:bytecomp:translobj.cmiÄ :typing:ident.cmi :bytecomp:lambda.cmi -:bytecomp:typeopt.cmiÄ :bytecomp:lambda.cmi :typing:path.cmi ¶ - :typing:typedtree.cmi -:bytecomp:bytegen.cmoÄ :parsing:asttypes.cmi :utils:config.cmi ¶ - :typing:ident.cmi :bytecomp:instruct.cmi :bytecomp:lambda.cmi ¶ - :utils:misc.cmi :typing:primitive.cmi :bytecomp:switch.cmi ¶ - :typing:types.cmi :bytecomp:bytegen.cmi -:bytecomp:bytegen.cmxÄ :parsing:asttypes.cmi :utils:config.cmx ¶ - :typing:ident.cmx :bytecomp:instruct.cmx :bytecomp:lambda.cmx ¶ - :utils:misc.cmx :typing:primitive.cmx :bytecomp:switch.cmx ¶ - :typing:types.cmx :bytecomp:bytegen.cmi -:bytecomp:bytelibrarian.cmoÄ :utils:clflags.cmo :utils:config.cmi ¶ - :bytecomp:emitcode.cmi :utils:misc.cmi :bytecomp:bytelibrarian.cmi -:bytecomp:bytelibrarian.cmxÄ :utils:clflags.cmx :utils:config.cmx ¶ - :bytecomp:emitcode.cmx :utils:misc.cmx :bytecomp:bytelibrarian.cmi -:bytecomp:bytelink.cmoÄ :bytecomp:bytesections.cmi :utils:ccomp.cmi ¶ - :utils:clflags.cmo :utils:config.cmi :bytecomp:emitcode.cmi ¶ - :typing:ident.cmi :bytecomp:instruct.cmi :utils:misc.cmi ¶ - :bytecomp:opcodes.cmo :bytecomp:symtable.cmi :bytecomp:bytelink.cmi -:bytecomp:bytelink.cmxÄ :bytecomp:bytesections.cmx :utils:ccomp.cmx ¶ - :utils:clflags.cmx :utils:config.cmx :bytecomp:emitcode.cmx ¶ - :typing:ident.cmx :bytecomp:instruct.cmx :utils:misc.cmx ¶ - :bytecomp:opcodes.cmx :bytecomp:symtable.cmx :bytecomp:bytelink.cmi -:bytecomp:bytesections.cmoÄ :utils:config.cmi :bytecomp:bytesections.cmi -:bytecomp:bytesections.cmxÄ :utils:config.cmx :bytecomp:bytesections.cmi -:bytecomp:emitcode.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :utils:config.cmi :typing:env.cmi :typing:ident.cmi ¶ - :bytecomp:instruct.cmi :bytecomp:lambda.cmi :bytecomp:meta.cmi ¶ - :utils:misc.cmi :bytecomp:opcodes.cmo :bytecomp:translmod.cmi ¶ - :bytecomp:emitcode.cmi -:bytecomp:emitcode.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :utils:config.cmx :typing:env.cmx :typing:ident.cmx ¶ - :bytecomp:instruct.cmx :bytecomp:lambda.cmx :bytecomp:meta.cmx ¶ - :utils:misc.cmx :bytecomp:opcodes.cmx :bytecomp:translmod.cmx ¶ - :bytecomp:emitcode.cmi -:bytecomp:instruct.cmoÄ :typing:env.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :typing:types.cmi :bytecomp:instruct.cmi -:bytecomp:instruct.cmxÄ :typing:env.cmx :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :typing:types.cmx :bytecomp:instruct.cmi -:bytecomp:lambda.cmoÄ :parsing:asttypes.cmi :typing:env.cmi :typing:ident.cmi ¶ - :utils:misc.cmi :typing:path.cmi :typing:primitive.cmi :typing:types.cmi ¶ - :bytecomp:lambda.cmi -:bytecomp:lambda.cmxÄ :parsing:asttypes.cmi :typing:env.cmx :typing:ident.cmx ¶ - :utils:misc.cmx :typing:path.cmx :typing:primitive.cmx :typing:types.cmx ¶ - :bytecomp:lambda.cmi -:bytecomp:matching.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :typing:ident.cmi :bytecomp:lambda.cmi :parsing:location.cmi ¶ - :utils:misc.cmi :typing:parmatch.cmi :typing:predef.cmi ¶ - :typing:primitive.cmi :bytecomp:printlambda.cmi :bytecomp:switch.cmi ¶ - :typing:typedtree.cmi :bytecomp:typeopt.cmi :typing:types.cmi ¶ - :bytecomp:matching.cmi -:bytecomp:matching.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :typing:ident.cmx :bytecomp:lambda.cmx :parsing:location.cmx ¶ - :utils:misc.cmx :typing:parmatch.cmx :typing:predef.cmx ¶ - :typing:primitive.cmx :bytecomp:printlambda.cmx :bytecomp:switch.cmx ¶ - :typing:typedtree.cmx :bytecomp:typeopt.cmx :typing:types.cmx ¶ - :bytecomp:matching.cmi -:bytecomp:meta.cmoÄ :bytecomp:meta.cmi -:bytecomp:meta.cmxÄ :bytecomp:meta.cmi -:bytecomp:printinstr.cmoÄ :typing:ident.cmi :bytecomp:instruct.cmi ¶ - :bytecomp:lambda.cmi :bytecomp:printlambda.cmi :bytecomp:printinstr.cmi -:bytecomp:printinstr.cmxÄ :typing:ident.cmx :bytecomp:instruct.cmx ¶ - :bytecomp:lambda.cmx :bytecomp:printlambda.cmx :bytecomp:printinstr.cmi -:bytecomp:printlambda.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :typing:primitive.cmi :typing:types.cmi ¶ - :bytecomp:printlambda.cmi -:bytecomp:printlambda.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :typing:primitive.cmx :typing:types.cmx ¶ - :bytecomp:printlambda.cmi -:bytecomp:runtimedef.cmoÄ :bytecomp:runtimedef.cmi -:bytecomp:runtimedef.cmxÄ :bytecomp:runtimedef.cmi -:bytecomp:simplif.cmoÄ :parsing:asttypes.cmi :utils:clflags.cmo ¶ - :typing:ident.cmi :bytecomp:lambda.cmi :bytecomp:simplif.cmi -:bytecomp:simplif.cmxÄ :parsing:asttypes.cmi :utils:clflags.cmx ¶ - :typing:ident.cmx :bytecomp:lambda.cmx :bytecomp:simplif.cmi -:bytecomp:switch.cmoÄ :bytecomp:switch.cmi -:bytecomp:switch.cmxÄ :bytecomp:switch.cmi -:bytecomp:symtable.cmoÄ :parsing:asttypes.cmi :bytecomp:bytesections.cmi ¶ - :utils:clflags.cmo :bytecomp:emitcode.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :bytecomp:meta.cmi :utils:misc.cmi ¶ - :typing:predef.cmi :bytecomp:runtimedef.cmi :utils:tbl.cmi ¶ - :bytecomp:symtable.cmi -:bytecomp:symtable.cmxÄ :parsing:asttypes.cmi :bytecomp:bytesections.cmx ¶ - :utils:clflags.cmx :bytecomp:emitcode.cmx :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :bytecomp:meta.cmx :utils:misc.cmx ¶ - :typing:predef.cmx :bytecomp:runtimedef.cmx :utils:tbl.cmx ¶ - :bytecomp:symtable.cmi -:bytecomp:translclass.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :parsing:location.cmi :bytecomp:matching.cmi ¶ - :utils:misc.cmi :bytecomp:translcore.cmi :bytecomp:translobj.cmi ¶ - :typing:typedtree.cmi :bytecomp:typeopt.cmi :typing:types.cmi ¶ - :bytecomp:translclass.cmi -:bytecomp:translclass.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :parsing:location.cmx :bytecomp:matching.cmx ¶ - :utils:misc.cmx :bytecomp:translcore.cmx :bytecomp:translobj.cmx ¶ - :typing:typedtree.cmx :bytecomp:typeopt.cmx :typing:types.cmx ¶ - :bytecomp:translclass.cmi -:bytecomp:translcore.cmoÄ :parsing:asttypes.cmi :typing:btype.cmi ¶ - :utils:clflags.cmo :utils:config.cmi :typing:env.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :parsing:location.cmi :bytecomp:matching.cmi ¶ - :utils:misc.cmi :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶ - :bytecomp:translobj.cmi :typing:typedtree.cmi :bytecomp:typeopt.cmi ¶ - :typing:types.cmi :bytecomp:translcore.cmi -:bytecomp:translcore.cmxÄ :parsing:asttypes.cmi :typing:btype.cmx ¶ - :utils:clflags.cmx :utils:config.cmx :typing:env.cmx :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :parsing:location.cmx :bytecomp:matching.cmx ¶ - :utils:misc.cmx :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶ - :bytecomp:translobj.cmx :typing:typedtree.cmx :bytecomp:typeopt.cmx ¶ - :typing:types.cmx :bytecomp:translcore.cmi -:bytecomp:translmod.cmoÄ :parsing:asttypes.cmi :typing:ident.cmi ¶ - :bytecomp:lambda.cmi :utils:misc.cmi :typing:path.cmi ¶ - :typing:primitive.cmi :bytecomp:translclass.cmi :bytecomp:translcore.cmi ¶ - :bytecomp:translobj.cmi :typing:typedtree.cmi :typing:types.cmi ¶ - :bytecomp:translmod.cmi -:bytecomp:translmod.cmxÄ :parsing:asttypes.cmi :typing:ident.cmx ¶ - :bytecomp:lambda.cmx :utils:misc.cmx :typing:path.cmx ¶ - :typing:primitive.cmx :bytecomp:translclass.cmx :bytecomp:translcore.cmx ¶ - :bytecomp:translobj.cmx :typing:typedtree.cmx :typing:types.cmx ¶ - :bytecomp:translmod.cmi -:bytecomp:translobj.cmoÄ :parsing:asttypes.cmi :typing:env.cmi ¶ - :typing:ident.cmi :bytecomp:lambda.cmi :parsing:longident.cmi ¶ - :utils:misc.cmi :bytecomp:translobj.cmi -:bytecomp:translobj.cmxÄ :parsing:asttypes.cmi :typing:env.cmx ¶ - :typing:ident.cmx :bytecomp:lambda.cmx :parsing:longident.cmx ¶ - :utils:misc.cmx :bytecomp:translobj.cmi -:bytecomp:typeopt.cmoÄ :parsing:asttypes.cmi :typing:ctype.cmi ¶ - :typing:env.cmi :typing:ident.cmi :bytecomp:lambda.cmi :utils:misc.cmi ¶ - :typing:path.cmi :typing:predef.cmi :typing:primitive.cmi ¶ - :typing:typedtree.cmi :typing:types.cmi :bytecomp:typeopt.cmi -:bytecomp:typeopt.cmxÄ :parsing:asttypes.cmi :typing:ctype.cmx ¶ - :typing:env.cmx :typing:ident.cmx :bytecomp:lambda.cmx :utils:misc.cmx ¶ - :typing:path.cmx :typing:predef.cmx :typing:primitive.cmx ¶ - :typing:typedtree.cmx :typing:types.cmx :bytecomp:typeopt.cmi -:driver:compile.cmiÄ :typing:env.cmi -:driver:optcompile.cmiÄ :typing:env.cmi -:driver:compile.cmoÄ :bytecomp:bytegen.cmi :utils:ccomp.cmi ¶ - :utils:clflags.cmo :utils:config.cmi :bytecomp:emitcode.cmi ¶ - :typing:env.cmi :parsing:location.cmi :utils:misc.cmi :parsing:parse.cmi ¶ - :parsing:printast.cmi :bytecomp:printinstr.cmi :bytecomp:printlambda.cmi ¶ - :typing:printtyp.cmi :bytecomp:simplif.cmi :bytecomp:translmod.cmi ¶ - :typing:typedtree.cmi :typing:typemod.cmi :utils:warnings.cmi ¶ - :driver:compile.cmi -:driver:compile.cmxÄ :bytecomp:bytegen.cmx :utils:ccomp.cmx ¶ - :utils:clflags.cmx :utils:config.cmx :bytecomp:emitcode.cmx ¶ - :typing:env.cmx :parsing:location.cmx :utils:misc.cmx :parsing:parse.cmx ¶ - :parsing:printast.cmx :bytecomp:printinstr.cmx :bytecomp:printlambda.cmx ¶ - :typing:printtyp.cmx :bytecomp:simplif.cmx :bytecomp:translmod.cmx ¶ - :typing:typedtree.cmx :typing:typemod.cmx :utils:warnings.cmx ¶ - :driver:compile.cmi -:driver:errors.cmoÄ :bytecomp:bytelibrarian.cmi :bytecomp:bytelink.cmi ¶ - :typing:ctype.cmi :typing:env.cmi :typing:includemod.cmi ¶ - :parsing:lexer.cmi :parsing:location.cmi :bytecomp:symtable.cmi ¶ - :parsing:syntaxerr.cmi :bytecomp:translclass.cmi :bytecomp:translcore.cmi ¶ - :typing:typeclass.cmi :typing:typecore.cmi :typing:typedecl.cmi ¶ - :typing:typemod.cmi :typing:typetexp.cmi :utils:warnings.cmi ¶ - :driver:errors.cmi -:driver:errors.cmxÄ :bytecomp:bytelibrarian.cmx :bytecomp:bytelink.cmx ¶ - :typing:ctype.cmx :typing:env.cmx :typing:includemod.cmx ¶ - :parsing:lexer.cmx :parsing:location.cmx :bytecomp:symtable.cmx ¶ - :parsing:syntaxerr.cmx :bytecomp:translclass.cmx :bytecomp:translcore.cmx ¶ - :typing:typeclass.cmx :typing:typecore.cmx :typing:typedecl.cmx ¶ - :typing:typemod.cmx :typing:typetexp.cmx :utils:warnings.cmx ¶ - :driver:errors.cmi -:driver:main.cmoÄ :bytecomp:bytelibrarian.cmi :bytecomp:bytelink.cmi ¶ - :utils:clflags.cmo :driver:compile.cmi :utils:config.cmi ¶ - :driver:errors.cmi :driver:main_args.cmi :utils:warnings.cmi ¶ - :driver:main.cmi -:driver:main.cmxÄ :bytecomp:bytelibrarian.cmx :bytecomp:bytelink.cmx ¶ - :utils:clflags.cmx :driver:compile.cmx :utils:config.cmx ¶ - :driver:errors.cmx :driver:main_args.cmx :utils:warnings.cmx ¶ - :driver:main.cmi -:driver:main_args.cmoÄ :driver:main_args.cmi -:driver:main_args.cmxÄ :driver:main_args.cmi -:driver:optcompile.cmoÄ :utils:ccomp.cmi :utils:clflags.cmo :utils:config.cmi ¶ - :typing:env.cmi :parsing:location.cmi :utils:misc.cmi :parsing:parse.cmi ¶ - :parsing:printast.cmi :bytecomp:printlambda.cmi :typing:printtyp.cmi ¶ - :bytecomp:simplif.cmi :bytecomp:translmod.cmi :typing:typedtree.cmi ¶ - :typing:typemod.cmi :utils:warnings.cmi :driver:optcompile.cmi -:driver:optcompile.cmxÄ :utils:ccomp.cmx :utils:clflags.cmx :utils:config.cmx ¶ - :typing:env.cmx :parsing:location.cmx :utils:misc.cmx :parsing:parse.cmx ¶ - :parsing:printast.cmx :bytecomp:printlambda.cmx :typing:printtyp.cmx ¶ - :bytecomp:simplif.cmx :bytecomp:translmod.cmx :typing:typedtree.cmx ¶ - :typing:typemod.cmx :utils:warnings.cmx :driver:optcompile.cmi -:driver:opterrors.cmoÄ :typing:ctype.cmi :typing:env.cmi ¶ - :typing:includemod.cmi :parsing:lexer.cmi :parsing:location.cmi ¶ - :parsing:syntaxerr.cmi :bytecomp:translclass.cmi :bytecomp:translcore.cmi ¶ - :typing:typeclass.cmi :typing:typecore.cmi :typing:typedecl.cmi ¶ - :typing:typemod.cmi :typing:typetexp.cmi :utils:warnings.cmi ¶ - :driver:opterrors.cmi -:driver:opterrors.cmxÄ :typing:ctype.cmx :typing:env.cmx ¶ - :typing:includemod.cmx :parsing:lexer.cmx :parsing:location.cmx ¶ - :parsing:syntaxerr.cmx :bytecomp:translclass.cmx :bytecomp:translcore.cmx ¶ - :typing:typeclass.cmx :typing:typecore.cmx :typing:typedecl.cmx ¶ - :typing:typemod.cmx :typing:typetexp.cmx :utils:warnings.cmx ¶ - :driver:opterrors.cmi -:driver:optmain.cmoÄ :utils:clflags.cmo :utils:config.cmi ¶ - :driver:optcompile.cmi :driver:opterrors.cmi :utils:warnings.cmi ¶ - :driver:optmain.cmi -:driver:optmain.cmxÄ :utils:clflags.cmx :utils:config.cmx ¶ - :driver:optcompile.cmx :driver:opterrors.cmx :utils:warnings.cmx ¶ - :driver:optmain.cmi -:toplevel:genprintval.cmiÄ :typing:env.cmi :typing:outcometree.cmi ¶ - :typing:path.cmi :typing:types.cmi -:toplevel:topdirs.cmiÄ :parsing:longident.cmi -:toplevel:toploop.cmiÄ :typing:env.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :typing:outcometree.cmi :parsing:parsetree.cmi ¶ - :typing:path.cmi :typing:types.cmi :utils:warnings.cmi -:toplevel:trace.cmiÄ :typing:env.cmi :parsing:longident.cmi :typing:path.cmi ¶ - :typing:types.cmi -:toplevel:expunge.cmoÄ :bytecomp:bytesections.cmi :typing:ident.cmi ¶ - :utils:misc.cmi :bytecomp:runtimedef.cmi :bytecomp:symtable.cmi -:toplevel:expunge.cmxÄ :bytecomp:bytesections.cmx :typing:ident.cmx ¶ - :utils:misc.cmx :bytecomp:runtimedef.cmx :bytecomp:symtable.cmx -:toplevel:genprintval.cmoÄ :typing:btype.cmi :typing:ctype.cmi ¶ - :typing:datarepr.cmi :typing:env.cmi :typing:ident.cmi ¶ - :parsing:longident.cmi :utils:misc.cmi :typing:outcometree.cmi ¶ - :typing:path.cmi :typing:predef.cmi :typing:printtyp.cmi ¶ - :typing:types.cmi :toplevel:genprintval.cmi -:toplevel:genprintval.cmxÄ :typing:btype.cmx :typing:ctype.cmx ¶ - :typing:datarepr.cmx :typing:env.cmx :typing:ident.cmx ¶ - :parsing:longident.cmx :utils:misc.cmx :typing:outcometree.cmi ¶ - :typing:path.cmx :typing:predef.cmx :typing:printtyp.cmx ¶ - :typing:types.cmx :toplevel:genprintval.cmi -:toplevel:topdirs.cmoÄ :bytecomp:bytelink.cmi :utils:clflags.cmo ¶ - :utils:config.cmi :typing:ctype.cmi :bytecomp:emitcode.cmi ¶ - :typing:env.cmi :typing:ident.cmi :parsing:longident.cmi ¶ - :bytecomp:meta.cmi :utils:misc.cmi :bytecomp:opcodes.cmo :typing:path.cmi ¶ - :typing:printtyp.cmi :bytecomp:symtable.cmi :toplevel:toploop.cmi ¶ - :toplevel:trace.cmi :typing:types.cmi :utils:warnings.cmi ¶ - :toplevel:topdirs.cmi -:toplevel:topdirs.cmxÄ :bytecomp:bytelink.cmx :utils:clflags.cmx ¶ - :utils:config.cmx :typing:ctype.cmx :bytecomp:emitcode.cmx ¶ - :typing:env.cmx :typing:ident.cmx :parsing:longident.cmx ¶ - :bytecomp:meta.cmx :utils:misc.cmx :bytecomp:opcodes.cmx :typing:path.cmx ¶ - :typing:printtyp.cmx :bytecomp:symtable.cmx :toplevel:toploop.cmx ¶ - :toplevel:trace.cmx :typing:types.cmx :utils:warnings.cmx ¶ - :toplevel:topdirs.cmi -:toplevel:toploop.cmoÄ :bytecomp:bytegen.cmi :utils:clflags.cmo ¶ - :driver:compile.cmi :utils:config.cmi :bytecomp:emitcode.cmi ¶ - :typing:env.cmi :driver:errors.cmi :toplevel:genprintval.cmi ¶ - :typing:ident.cmi :parsing:lexer.cmi :parsing:location.cmi ¶ - :parsing:longident.cmi :bytecomp:meta.cmi :utils:misc.cmi ¶ - :typing:outcometree.cmi :parsing:parse.cmi :parsing:parsetree.cmi ¶ - :typing:path.cmi :typing:predef.cmi :parsing:printast.cmi ¶ - :bytecomp:printinstr.cmi :bytecomp:printlambda.cmi :typing:printtyp.cmi ¶ - :bytecomp:simplif.cmi :bytecomp:symtable.cmi :bytecomp:translmod.cmi ¶ - :typing:typedtree.cmi :typing:typemod.cmi :typing:types.cmi ¶ - :utils:warnings.cmi :toplevel:toploop.cmi -:toplevel:toploop.cmxÄ :bytecomp:bytegen.cmx :utils:clflags.cmx ¶ - :driver:compile.cmx :utils:config.cmx :bytecomp:emitcode.cmx ¶ - :typing:env.cmx :driver:errors.cmx :toplevel:genprintval.cmx ¶ - :typing:ident.cmx :parsing:lexer.cmx :parsing:location.cmx ¶ - :parsing:longident.cmx :bytecomp:meta.cmx :utils:misc.cmx ¶ - :typing:outcometree.cmi :parsing:parse.cmx :parsing:parsetree.cmi ¶ - :typing:path.cmx :typing:predef.cmx :parsing:printast.cmx ¶ - :bytecomp:printinstr.cmx :bytecomp:printlambda.cmx :typing:printtyp.cmx ¶ - :bytecomp:simplif.cmx :bytecomp:symtable.cmx :bytecomp:translmod.cmx ¶ - :typing:typedtree.cmx :typing:typemod.cmx :typing:types.cmx ¶ - :utils:warnings.cmx :toplevel:toploop.cmi -:toplevel:topmain.cmoÄ :utils:clflags.cmo :utils:config.cmi :utils:misc.cmi ¶ - :toplevel:toploop.cmi :utils:warnings.cmi -:toplevel:topmain.cmxÄ :utils:clflags.cmx :utils:config.cmx :utils:misc.cmx ¶ - :toplevel:toploop.cmx :utils:warnings.cmx -:toplevel:trace.cmoÄ :typing:ctype.cmi :parsing:longident.cmi ¶ - :bytecomp:meta.cmi :utils:misc.cmi :typing:path.cmi :typing:predef.cmi ¶ - :typing:printtyp.cmi :toplevel:toploop.cmi :typing:types.cmi ¶ - :toplevel:trace.cmi -:toplevel:trace.cmxÄ :typing:ctype.cmx :parsing:longident.cmx ¶ - :bytecomp:meta.cmx :utils:misc.cmx :typing:path.cmx :typing:predef.cmx ¶ - :typing:printtyp.cmx :toplevel:toploop.cmx :typing:types.cmx ¶ - :toplevel:trace.cmi diff --git a/README b/README index 400812aa..dbffb824 100644 --- a/README +++ b/README @@ -21,15 +21,14 @@ 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 + PowerPC processors: PowerMacintosh under MacOS X and LinuxPPC. AMD64 (Opteron) processors: PCs under Linux. Alpha processors: Digital/Compaq/HP Alpha machines under Digital Unix/Compaq Tru64, Linux, NetBSD and OpenBSD. Sparc processors: Sun Sparc machines under Solaris 2, NetBSD, Linux Mips processors: SGI workstations and mainframes under IRIX 6 Intel IA64 processors: HP stations under Linux - HP PA-RISC processors: HP 9000/700 under HPUX 10 + HP PA-RISC processors: HP 9000/700 under HPUX 10 and Linux Strong ARM processors: Corel Netwinder under Linux Other operating systems for the processors above have not been tested, @@ -108,7 +107,7 @@ There exists a mailing list of users of the Caml implementations developed at INRIA. The purpose of this list is to share experience, exchange ideas (and even code), and report on applications of the Caml language. Messages can be written in English or in -French. The list has about 500 subscribers. +French. The list has about 750 subscribers. Messages to the list should be sent to: diff --git a/README.win32 b/README.win32 index c872c3eb..5db615b2 100644 --- a/README.win32 +++ b/README.win32 @@ -103,8 +103,7 @@ You will need the following software components to perform the recompilation: - Windows NT, 2000, or XP (we advise against compiling under Windows 95/98/ME) - Visual C++ version 6 or 7 - MASM version 6.11 (see above) -- The CygWin port of GNU tools, available from - http://sourceware.cygnus.com/cygwin/ +- The Cygwin port of GNU tools, available from http://cygwin.com/ - TCL/TK version 8.3 (for the LablTK GUI) (see above). Remember to add the directory where the libraries tk83.lib and @@ -149,7 +148,8 @@ 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 graphical user interface for the toplevel was initially developed +by Jacob Navia, then significantly improved by Christopher A. Watford. ------------------------------------------------------------------------------ @@ -186,6 +186,10 @@ You will need the following software components to perform the recompilation: - Cygwin: http://sourceware.cygnus.com/cygwin/ - TCL/TK version 8.3 (see above). +Do *not* install the standalone distribution of MinGW, nor the +companion MSYS tools: these have problems with long command lines. +Instead, use the version of MinGW that is installed along with Cygwin. + 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 diff --git a/Upgrading b/Upgrading index fac60423..10fdd47c 100644 --- a/Upgrading +++ b/Upgrading @@ -4,7 +4,7 @@ I Installation Q1: When compiling the distribution, I am getting strange linking - errors in otherlibraries. + errors in "otherlibraries". A1: This is probably a problem with dynamic linking. You can disable it with ./configure -no-shared-libs. If you really want to use @@ -91,7 +91,7 @@ A8: The new default mode is more flexible than the original commuting mode, so that you shouldn't see too much differences when using labeled libraries. Labels are only compulsory in partial applications (including the special case of function with an - unkwnown return type), or if you wrote some of them. + unknown return type), or if you wrote some of them. On the other hand, for definitions, labels present in the interface must also be present in the implementation. diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp index af7469dd..55b260fe 100644 --- a/asmcomp/alpha/emit.mlp +++ b/asmcomp/alpha/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.37 2003/04/25 12:26:59 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.40 2004/05/03 12:46:50 xleroy Exp $ *) module LabelSet = Set.Make(struct type t = Linearize.label let compare = compare end) @@ -395,7 +395,7 @@ let emit_instr fallthrough i = | 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 + else if Int64.bits_of_float (float_of_string s) = 0L then ` fmov $f31, {emit_reg i.res.(0)}\n` else begin let lbl = new_label() in @@ -500,7 +500,7 @@ let emit_instr fallthrough i = ` bsr $26, caml_alloc3\n` | _ -> ` ldiq $25, {emit_int n}\n`; liveregs i live_25; - ` bsr $26, caml_alloc\n` + ` bsr $26, caml_allocN\n` end; (* $gp preserved by caml_alloc* *) `{record_frame i.live} addq $13, 8, {emit_reg i.res.(0)}\n` @@ -748,7 +748,7 @@ let emit_fundecl (fundecl, needs_gp) = 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` + ` br $26, caml_ml_array_bound_error\n` (* Keep retaddr in $26 for debugging *) end; ` .end {emit_symbol fundecl.fun_name}\n`; @@ -834,26 +834,26 @@ let begin_assembly() = 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 + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl_frame = Compilenv.make_symbol (Some "frametable") in ` {emit_string rdata_section}\n`; ` .globl {emit_symbol lbl_frame}\n`; `{emit_symbol lbl_frame}:\n`; diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index e73abe49..c3b85161 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.2 2003/06/30 11:29:26 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.6.6.1 2004/07/01 16:09:03 xleroy Exp $ *) (* Emission of Intel 386 assembly code *) @@ -299,10 +299,10 @@ let emit_instr fallthrough i = 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 + begin match Int64.bits_of_float (float_of_string s) with + | 0x0000_0000_0000_0000L -> (* +0.0 *) ` 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` @@ -380,7 +380,7 @@ let emit_instr fallthrough i = 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`; + ` cmpq {emit_symbol "caml_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`; @@ -395,7 +395,7 @@ let emit_instr fallthrough i = | 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` + ` call {emit_symbol "caml_allocN"}\n` end; `{record_frame i.live} leaq 8(%r15), {emit_reg i.res.(0)}\n` end @@ -562,29 +562,23 @@ let rec emit_all fallthrough i = let emit_float_constant (lbl, cst) = `{emit_label lbl}: .double {emit_string cst}\n` -(* Emission of the profiling prelude -- FIXME *) +(* 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`; + | "linux" -> + (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly + and rbx, rbp, r12-r15 like all C functions. + We need to preserve r10 and r11 ourselves, since Caml can + use them for argument passing. *) + ` pushq %r10\n`; + ` movq %rsp, %rbp\n`; + ` pushq %r11\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*) + ` popq %r11\n`; + ` popq %r10\n` + | _ -> + () (*unsupported yet*) (* Emission of a function declaration *) @@ -609,10 +603,10 @@ let fundecl fundecl = 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`; + `{emit_label !range_check_trap}: call {emit_symbol "caml_ml_array_bound_error"}\n`; (* Never returns, but useful to have retaddr on stack for debugging *) if !float_constants <> [] then begin - ` .section .rodata.cst8,\"aM\",@progbits,8\n`; + ` .section .rodata.cst8,\"a\",@progbits\n`; List.iter emit_float_constant !float_constants end @@ -655,26 +649,26 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = - let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl = Compilenv.make_symbol (Some "frametable") in ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; ` .quad {emit_int (List.length !frame_descriptors)}\n`; diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 0670610a..d6d85d0b 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.15 2003/04/25 12:26:59 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.18 2004/05/03 12:46:50 xleroy Exp $ *) (* Emission of ARM assembly code *) @@ -305,9 +305,10 @@ let emit_instr i = end else emit_complex_intconst r n | Lop(Iconst_float s) -> - if float_of_string s = 0.0 then + begin match Int64.bits_of_float (float_of_string s) with + | 0x0000_0000_0000_0000L -> (* +0.0 *) ` 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` @@ -402,7 +403,7 @@ let emit_instr i = ` 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`; + `{record_frame i.live} bl caml_allocN\n`; ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 2 + ni end @@ -416,7 +417,7 @@ let emit_instr i = ` 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 + ` blls caml_ml_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 @@ -453,7 +454,7 @@ let emit_instr i = ` 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 + ` blls caml_ml_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 @@ -472,7 +473,7 @@ let emit_instr i = 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 + ` blcs caml_ml_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 -> @@ -650,26 +651,26 @@ let begin_assembly() = `sp .req r13\n`; `lr .req r14\n`; `pc .req r15\n`; - let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl = Compilenv.make_symbol (Some "frametable") in ` .data\n`; ` .global {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index a66b6052..fc197ed7 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: asmlink.ml,v 1.62 2003/06/27 08:49:22 xleroy Exp $ *) +(* $Id: asmlink.ml,v 1.65 2004/05/26 11:10:27 garrigue Exp $ *) (* Link a set of .cmx/.o files and produce an executable *) @@ -167,21 +167,24 @@ 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 *) + Location.input_name := "caml_startup"; (* set name of "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 + let send_functions = ref IntSet.empty in + 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 -> send_functions := IntSet.add n !send_functions) + info.ui_send_fun; List.iter (fun n -> curry_functions := IntSet.add n !curry_functions) info.ui_curry_fun) @@ -189,6 +192,9 @@ let make_startup_file ppf filename units_list = IntSet.iter (fun n -> compile_phrase (Cmmgen.apply_function n)) !apply_functions; + IntSet.iter + (fun n -> compile_phrase (Cmmgen.send_function n)) + !send_functions; IntSet.iter (fun n -> List.iter (compile_phrase) (Cmmgen.curry_function n)) !curry_functions; @@ -203,10 +209,10 @@ let make_startup_file ppf filename units_list = 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.data_segment_table ("_startup" :: name_list)); + compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); compile_phrase - (Cmmgen.frame_table("startup" :: "system" :: name_list)); + (Cmmgen.frame_table("_startup" :: "_system" :: name_list)); Emit.end_assembly(); close_out oc diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 828d255d..ea2db5d9 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: asmpackager.ml,v 1.8 2003/07/03 16:21:47 xleroy Exp $ *) +(* $Id: asmpackager.ml,v 1.14 2004/05/26 11:10:27 garrigue Exp $ *) (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) @@ -33,31 +33,48 @@ 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 +type pack_member_kind = PM_intf | PM_impl of unit_infos + +type pack_member = + { pm_file: string; + pm_name: string; + pm_kind: pack_member_kind } + +let read_member_info file = + let name = + String.capitalize(Filename.basename(chop_extension_if_any file)) in + let kind = + if Filename.check_suffix file ".cmx" then begin + let (info, crc) = Compilenv.read_unit_info file in + if info.ui_name <> name + then raise(Error(Illegal_renaming(file, info.ui_name))); + Asmlink.check_consistency file info crc; + PM_impl info + end else + PM_intf in + { pm_file = file; pm_name = name; pm_kind = kind } (* Check absence of forward references *) -let check_units cmxfiles units unit_names = +let check_units members = 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) + | mb :: tl -> + begin match mb.pm_kind with + | PM_intf -> () + | PM_impl infos -> + List.iter + (fun (unit, _) -> + if List.mem unit forbidden + then raise(Error(Forward_reference(mb.pm_file, unit)))) + infos.ui_imports_cmx + end; + check (list_remove mb.pm_name forbidden) tl in + check (List.map (fun mb -> mb.pm_name) members) members (* 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. *) + caml[T] or caml[T]__xxx, where [T] belongs to the list [units], are + replaced by caml[pref]__[T]__xxx . Return the list of renamed symbols. *) let extract_symbols units symbolfile = let symbs = ref [] in @@ -66,12 +83,14 @@ let extract_symbols units symbolfile = 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 i = 3 + (try search_substring " T " l 0 with Not_found -> + try search_substring " D " l 0 with Not_found -> + search_substring " R " 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 + if j - k > 4 && String.sub l k 4 = "caml" + && List.mem (String.sub l (k + 4) (j - k - 4)) units then symbs := (String.sub l i (String.length l - i)) :: !symbs with Not_found -> () @@ -83,17 +102,31 @@ let extract_symbols units symbolfile = let max_cmdline_length = 3500 (* safe approximation *) -let remove_leading_underscore s = +(* Turn a low-level ident (with leading "caml" or "_caml") back into + a high-level ident. +*) +let remove_leading_caml s = if String.length s > 0 && s.[0] = '_' - then String.sub s 1 (String.length s - 1) - else s + then String.sub s 5 (String.length s - 5) + else String.sub s 4 (String.length s - 4) +(* Insert prefix [p] in a low-level ident (after the "caml" or "_caml" + prefix). +*) 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 = + if String.length s > 0 && s.[0] = '_' then begin + assert (String.length s > 5 && String.sub s 0 5 = "_caml"); + "_caml" ^ p ^ "__" ^ String.sub s 5 (String.length s - 5) + end else begin + assert (String.length s > 4 && String.sub s 0 4 = "caml"); + "caml" ^ p ^ "__" ^ String.sub s 4 (String.length s - 4) + end + +(* return the list of symbols to rename in low-level form + (with the leading "_caml" or "caml") +*) +let rename_in_object_file members pref objfile = + let units = List.map (fun m -> m.pm_name) members in let symbolfile = Filename.temp_file "camlsymbols" "" in try let nm_cmdline = @@ -125,20 +158,23 @@ let rename_in_object_file units pref objfile = Buffer.add_string cmdline Config.binutils_objcopy; call_objcopy symbols_to_rename; remove_file symbolfile; - List.map remove_leading_underscore symbols_to_rename + 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 rename_approx mapping_lbl mapping_id approx = let ren_label lbl = - try Tbl.find lbl mapping with Not_found -> lbl in + try Tbl.find lbl mapping_lbl with Not_found -> lbl in let ren_ident id = if Ident.persistent id - then Ident.create_persistent(ren_label(Ident.name id)) + then + let lbl = Ident.name id in + let newlbl = try Tbl.find lbl mapping_id with Not_found -> lbl in + Ident.create_persistent newlbl else id in let rec ren_ulambda = function @@ -186,8 +222,8 @@ let rename_approx mapping approx = 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 + | Usend(k, u1, u2, ul) -> + Usend(k, ren_ulambda u1, ren_ulambda u2, List.map ren_ulambda ul) in let rec ren_approx = function Value_closure(fd, res) -> @@ -207,7 +243,9 @@ let rename_approx mapping approx = (* Make the .cmx file for the package *) -let build_package_cmx units unit_names target symbols_to_rename cmxfile = +let build_package_cmx members target symbols_to_rename cmxfile = + let unit_names = + List.map (fun m -> m.pm_name) members in let filter lst = List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in let union lst = @@ -215,13 +253,27 @@ let build_package_cmx units unit_names target symbols_to_rename cmxfile = (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) + let mapping_id = + let map_id tbl s = + let high_s = remove_leading_caml s in + Tbl.add high_s (target ^ "__" ^ high_s) tbl + in + List.fold_left map_id Tbl.empty symbols_to_rename + in + let mapping_lbl = + List.fold_left (fun tbl s -> Tbl.add s (prefix_symbol target s) tbl) Tbl.empty symbols_to_rename in + let member_defines m = + match m.pm_kind with PM_intf -> [] | PM_impl info -> info.ui_defines in let defines = map_end (fun s -> target ^ "__" ^ s) - (List.concat (List.map (fun info -> info.ui_defines) units)) + (List.concat (List.map member_defines members)) [target] in + let units = + List.fold_left + (fun accu m -> + match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu) + [] members in let approx = Compilenv.global_approx (Ident.create_persistent target) in let pkg_infos = @@ -230,25 +282,35 @@ let build_package_cmx units unit_names target symbols_to_rename cmxfile = 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_approx = rename_approx mapping_lbl mapping_id 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_send_fun = union(List.map (fun info -> info.ui_send_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 make_package_object ppf members 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 *) + let components = + List.map + (fun m -> + match m.pm_kind with + | PM_intf -> None + | PM_impl _ -> Some(Ident.create_persistent m.pm_name)) + members in 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); + components (Ident.create_persistent targetname) coercion); + let objfiles = + List.map + (fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj) + (List.filter (fun m -> m.pm_kind <> PM_intf) members) in let ld_cmd = sprintf "%s -o %s %s %s" Config.native_pack_linker @@ -261,23 +323,20 @@ let make_package_object ppf unit_names objfiles (* Make the .cmx and the .o for the package *) -let package_object_files ppf cmxfiles targetcmx +let package_object_files ppf files 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 + let members = map_left_right read_member_info files in + check_units members; + make_package_object ppf members targetobj targetname coercion; + let symbols = rename_in_object_file members targetname targetobj in + build_package_cmx members 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 = + let files = List.map (fun f -> try find_in_path !Config.load_path f @@ -288,8 +347,8 @@ let package_files ppf files targetcmx = 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 + let coercion = Typemod.package_units files targetcmi targetname in + package_object_files ppf files targetcmx targetobj targetname coercion with x -> remove_file targetcmx; remove_file targetobj; raise x diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 25d0b8c2..71ec1059 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: clambda.ml,v 1.15 2001/02/19 20:15:36 maranget Exp $ *) +(* $Id: clambda.ml,v 1.16 2004/05/26 11:10:27 garrigue Exp $ *) (* A variant of the "lambda" code with direct / indirect calls explicit and closures explicit too *) @@ -40,7 +40,7 @@ type 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 + | Usend of meth_kind * ulambda * ulambda * ulambda list and ulambda_switch = { us_index_consts: int array; diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index f536ac8e..84ccc78e 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: clambda.mli,v 1.15 2001/02/19 20:15:36 maranget Exp $ *) +(* $Id: clambda.mli,v 1.16 2004/05/26 11:10:27 garrigue Exp $ *) (* A variant of the "lambda" code with direct / indirect calls explicit and closures explicit too *) @@ -40,7 +40,7 @@ type 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 + | Usend of meth_kind * ulambda * ulambda * ulambda list and ulambda_switch = { us_index_consts: int array; diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 7595d63b..ffe2e6c2 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: closure.ml,v 1.42 2003/04/25 12:26:58 xleroy Exp $ *) +(* $Id: closure.ml,v 1.44 2004/05/26 11:10:27 garrigue Exp $ *) (* Introduction of closures, uncurrying, recognition of direct calls *) @@ -62,7 +62,7 @@ let occurs_var var u = | 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) -> + | Usend(_, met, obj, args) -> occurs met || occurs obj || List.exists occurs args and occurs_array a = try @@ -152,7 +152,7 @@ let lambda_smaller lam threshold = size := !size + 4; lambda_size low; lambda_size high; lambda_size body | Uassign(id, lam) -> incr size; lambda_size lam - | Usend(met, obj, args) -> + | 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 @@ -306,8 +306,8 @@ let rec substitute sb ulam = 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) + | Usend(k, u1, u2, ul) -> + Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul) (* Perform an inline expansion *) @@ -457,10 +457,10 @@ let rec close fenv cenv = function | ((ufunct, _), uargs) -> (Ugeneric_apply(ufunct, uargs), Value_unknown) end - | Lsend(met, obj, args) -> + | Lsend(kind, 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) + (Usend(kind, 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 @@ -616,8 +616,7 @@ and close_functions fenv cenv fun_defs = List.map (function (id, (Lfunction(kind, params, body) as def)) -> - let label = - Compilenv.current_unit_name() ^ "__" ^ Ident.unique_name id in + let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in let arity = List.length params in let fundesc = {fun_label = label; diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 519f7d59..c75cedda 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: cmmgen.ml,v 1.91 2003/04/25 13:26:55 xleroy Exp $ *) +(* $Id: cmmgen.ml,v 1.100 2004/05/26 11:10:27 garrigue Exp $ *) (* Translation from closed lambda to C-- *) @@ -154,6 +154,20 @@ let ignore_low_bit_int = function | Cop(Cor, [c; Cconst_int 1]) -> c | c -> c +let is_nonzero_constant = function + Cconst_int n -> n <> 0 + | Cconst_natint n -> n <> 0n + | _ -> false + +let safe_divmod op c1 c2 = + if !Clflags.fast || is_nonzero_constant c2 then + Cop(op, [c1; c2]) + else + bind "divisor" c2 (fun c2 -> + Cifthenelse(c2, + Cop(op, [c1; c2]), + Cop(Craise, [Cconst_symbol "caml_bucket_Division_by_zero"]))) + (* Bool *) let test_bool = function @@ -231,6 +245,9 @@ let get_tag ptr = Cop(Cload Byte_unsigned, [Cop(Cadda, [ptr; Cconst_int(tag_offset)])]) +let get_size ptr = + Cop(Clsr, [header ptr; Cconst_int 10]) + (* Array indexing *) let log2_size_addr = Misc.log2 size_addr @@ -273,7 +290,7 @@ 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), + Cop(Cextcall("caml_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]) @@ -298,13 +315,22 @@ let string_length exp = (* Message sending *) +let lookup_tag obj tag = + bind "tag" tag (fun tag -> + Cop(Cextcall("caml_get_public_method", typ_addr, false), [obj; tag])) + 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])])) + addr_array_ref table lab) + +let call_cached_method obj tag cache pos args = + let arity = List.length args in + let cache = array_indexing log2_size_addr cache pos in + Compilenv.need_send_fun arity; + Cop(Capply typ_addr, + Cconst_symbol("caml_send" ^ string_of_int arity) :: + obj :: tag :: cache :: args) (* Allocation *) @@ -318,7 +344,7 @@ let make_alloc_generic set_fn tag wordsize args = | 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), + Cop(Cextcall("caml_alloc", typ_addr, true), [Cconst_int wordsize; Cconst_int tag]), fill_fields 1 args) end @@ -388,7 +414,7 @@ let new_const_label () = let new_const_symbol () = incr const_label; - Compilenv.current_unit_name () ^ "__" ^ string_of_int !const_label + Compilenv.make_symbol (Some (string_of_int !const_label)) let structured_constants = ref ([] : (string * structured_constant) list) @@ -422,9 +448,9 @@ let box_int_constant bi n = let operations_boxed_int bi = match bi with - Pnativeint -> "nativeint_ops" - | Pint32 -> "int32_ops" - | Pint64 -> "int64_ops" + Pnativeint -> "caml_nativeint_ops" + | Pint32 -> "caml_int32_ops" + | Pint64 -> "caml_int64_ops" let box_int bi arg = match arg with @@ -562,30 +588,32 @@ let default_prim name = 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") + Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int") + | Pintofbint Pint64 -> Pccall (default_prim "caml_int64_to_int") + | Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "caml_int64_of_int32") + | Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "caml_int64_to_int32") + | Pcvtbint(Pnativeint, Pint64) -> + Pccall (default_prim "caml_int64_of_nativeint") + | Pcvtbint(Pint64, Pnativeint) -> + Pccall (default_prim "caml_int64_to_nativeint") + | Pnegbint Pint64 -> Pccall (default_prim "caml_int64_neg") + | Paddbint Pint64 -> Pccall (default_prim "caml_int64_add") + | Psubbint Pint64 -> Pccall (default_prim "caml_int64_sub") + | Pmulbint Pint64 -> Pccall (default_prim "caml_int64_mul") + | Pdivbint Pint64 -> Pccall (default_prim "caml_int64_div") + | Pmodbint Pint64 -> Pccall (default_prim "caml_int64_mod") + | Pandbint Pint64 -> Pccall (default_prim "caml_int64_and") + | Porbint Pint64 -> Pccall (default_prim "caml_int64_or") + | Pxorbint Pint64 -> Pccall (default_prim "caml_int64_xor") + | Plslbint Pint64 -> Pccall (default_prim "caml_int64_shift_left") + | Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned") + | Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right") + | Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal") + | Pbintcomp(Pint64, Lambda.Cneq) -> Pccall (default_prim "caml_notequal") + | Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan") + | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan") + | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") + | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal") | Pbigarrayref(n, Pbigarray_int64, layout) -> Pccall (default_prim ("bigarray_get_" ^ string_of_int n)) | Pbigarrayset(n, Pbigarray_int64, layout) -> @@ -790,17 +818,23 @@ let rec transl = function let cargs = Cconst_symbol(apply_function arity) :: List.map transl (args @ [clos]) in Cop(Capply typ_addr, cargs) - | Usend(met, obj, []) -> + | Usend(kind, met, obj, args) -> + let call_met obj args clos = + if args = [] then Cop(Capply typ_addr,[get_field clos 0;obj;clos]) else + let arity = List.length args + 1 in + let cargs = Cconst_symbol(apply_function arity) :: obj :: + (List.map transl args) @ [clos] in + Cop(Capply typ_addr, cargs) + in 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))) + match kind, args with + Self, _ -> + bind "met" (lookup_label obj (transl met)) (call_met obj args) + | Cached, cache :: pos :: args -> + call_cached_method obj (transl met) (transl cache) (transl pos) + (List.map transl args) + | _ -> + bind "met" (lookup_tag obj (transl met)) (call_met obj args)) | Ulet(id, exp, body) -> begin match is_unboxed_number exp with No_unboxing -> @@ -819,7 +853,10 @@ let rec transl = function | Uprim(prim, args) -> begin match (simplif_primitive prim, args) with (Pgetglobal id, []) -> - Cconst_symbol(Ident.name id) + if Ident.is_predef_exn id + then Cconst_symbol ("caml_exn_" ^ (Ident.name id)) + else Cconst_symbol (Compilenv.make_symbol ~unitname:(Ident.name id) + None) | (Pmakeblock(tag, mut), []) -> transl_constant(Const_block(tag, [])) | (Pmakeblock(tag, mut), args) -> @@ -842,7 +879,7 @@ let rec transl = function | (Pmakearray kind, args) -> begin match kind with Pgenarray -> - Cop(Cextcall("make_array", typ_addr, true), + Cop(Cextcall("caml_make_array", typ_addr, true), [make_alloc 0 (List.map transl args)]) | Paddrarray | Pintarray -> make_alloc 0 (List.map transl args) @@ -1067,7 +1104,7 @@ and transl_prim_2 p arg1 arg2 = (* Heap operations *) Psetfield(n, ptr) -> if ptr then - return_unit(Cop(Cextcall("modify", typ_void, false), + return_unit(Cop(Cextcall("caml_modify", typ_void, false), [field_address (transl arg1) n; transl arg2])) else return_unit(set_field (transl arg1) n (transl arg2)) @@ -1093,9 +1130,9 @@ and transl_prim_2 p arg1 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)])) + tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2))) | Pmodint -> - tag_int(Cop(Cmodi, [untag_int(transl arg1); untag_int(transl arg2)])) + tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2))) | Pandint -> Cop(Cand, [transl arg1; transl arg2]) | Porint -> @@ -1205,11 +1242,11 @@ and transl_prim_2 p arg1 arg2 = 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])) + box_int bi (safe_divmod 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])) + box_int bi (safe_divmod 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])) @@ -1437,7 +1474,8 @@ and transl_letrec bindings cont = 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]), + Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true), + [int_const sz]), init_blocks rem) | (id, exp, RHS_nonrec) :: rem -> Clet (id, Cconst_int 0, init_blocks rem) @@ -1449,7 +1487,7 @@ and transl_letrec bindings cont = and fill_blocks = function | [] -> cont | (id, exp, RHS_block _) :: rem -> - Csequence(Cop(Cextcall("update_dummy", typ_void, false), + Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false), [Cvar id; transl exp]), fill_blocks rem) | (id, exp, RHS_nonrec) :: rem -> @@ -1575,23 +1613,23 @@ and emit_string_constant s 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 + Csymbol_address("caml_int32_ops") :: Cint32 n :: Cint32 0n :: cont else - Csymbol_address("int32_ops") :: Cint n :: cont + Csymbol_address("caml_int32_ops") :: Cint n :: cont and emit_boxed_nativeint_constant n cont = - Csymbol_address("nativeint_ops") :: Cint n :: cont + Csymbol_address("caml_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 + Csymbol_address("caml_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 + Csymbol_address("caml_int64_ops") :: Cint hi :: Cint lo :: cont else - Csymbol_address("int64_ops") :: Cint lo :: Cint hi :: cont + Csymbol_address("caml_int64_ops") :: Cint lo :: Cint hi :: cont end (* Emit constant closures *) @@ -1644,9 +1682,10 @@ let emit_all_constants cont = (* Translate a compilation unit *) let compunit size ulam = - let glob = Compilenv.current_unit_name () in + let glob = Compilenv.make_symbol None in let init_code = transl ulam in - let c1 = [Cfunction {fun_name = glob ^ "__entry"; fun_args = []; + let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "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 @@ -1655,6 +1694,56 @@ let compunit size ulam = Cdefine_symbol glob; Cskip(size * size_addr)] :: c3 +(* +CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) +{ + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { // no need to check the 1st time + mi = ((li+hi) >> 1) | 1; + if (tag < Field(meths,mi)) hi = mi-2; + else li = mi; + } + *cache = (li-3)*sizeof(value)+1; + return Field (meths, li-1); +} +*) + +let cache_public_method meths tag cache = + let raise_num = next_raise_count () in + let li = Ident.create "li" and hi = Ident.create "hi" + and mi = Ident.create "mi" and tagged = Ident.create "tagged" in + Clet ( + li, Cconst_int 3, + Clet ( + hi, Cop(Cload Word, [meths]), + Csequence( + Ccatch + (raise_num, [], + Cloop + (Clet( + mi, + Cop(Cor, + [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]); + Cconst_int 1]), + Csequence( + Cifthenelse + (Cop (Ccmpi Clt, + [tag; + Cop(Cload Word, + [Cop(Cadda, + [meths; lsl_const (Cvar mi) log2_size_addr])])]), + Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])), + Cassign(li, Cvar mi)), + Cifthenelse + (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []), + Ctuple [])))), + Ctuple []), + Clet ( + tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr; + Cconst_int(1 - 3 * size_addr)]), + Csequence(Cop (Cstore Word, [cache; Cvar tagged]), + Cvar tagged))))) + (* Generate an application function: (defun caml_applyN (a1 ... aN clos) (if (= clos.arity N) @@ -1666,7 +1755,7 @@ let compunit size ulam = (app closN-1.code aN closN-1)))) *) -let apply_function arity = +let apply_function_body 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 @@ -1681,13 +1770,56 @@ let apply_function arity = [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 + let args = Array.to_list arg in + let all_args = args @ [clos] in + (args, clos, + if arity = 1 then app_fun clos 0 else + 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)) + +let send_function arity = + let (args, clos', body) = apply_function_body (1+arity) in + let cache = Ident.create "cache" + and obj = List.hd args + and tag = Ident.create "tag" in + let clos = + let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in + let meths = Ident.create "meths" and cached = Ident.create "cached" in + let real = Ident.create "real" in + let mask = get_field (Cvar meths) 1 in + let cached_pos = Cvar cached in + let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths]); + Cconst_int(3*size_addr-1)]) in + let tag' = Cop(Cload Word, [tag_pos]) in + Clet ( + meths, Cop(Cload Word, [obj]), + Clet ( + cached, Cop(Cand, [Cop(Cload Word, [cache]); mask]), + Clet ( + real, + Cifthenelse(Cop(Ccmpa Cne, [tag'; tag]), + cache_public_method (Cvar meths) tag cache, + cached_pos), + Cop(Cload Word, [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths]); + Cconst_int(2*size_addr-1)])])))) + + in + let body = Clet(clos', clos, body) in + let fun_args = + [obj, typ_addr; tag, typ_int; cache, typ_addr] + @ List.map (fun id -> (id, typ_addr)) (List.tl args) in + Cfunction + {fun_name = "caml_send" ^ string_of_int arity; + fun_args = fun_args; + fun_body = body; + fun_fast = true} + +let apply_function arity = + let (args, clos, body) = apply_function_body arity in + let all_args = args @ [clos] in Cfunction {fun_name = "caml_apply" ^ string_of_int arity; fun_args = List.map (fun id -> (id, typ_addr)) all_args; @@ -1783,7 +1915,8 @@ let entry_point namelist = let body = List.fold_right (fun name next -> - Csequence(Cop(Capply typ_void, [Cconst_symbol(name ^ "__entry")]), + let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in + Csequence(Cop(Capply typ_void, [Cconst_symbol entry_sym]), Csequence(incr_global_inited, next))) namelist (Cconst_int 1) in Cfunction {fun_name = "caml_program"; @@ -1796,44 +1929,56 @@ let entry_point namelist = let cint_zero = Cint 0n let global_table namelist = + let mksym name = + Csymbol_address (Compilenv.make_symbol ~unitname:name None) + in Cdata(Cglobal_symbol "caml_globals" :: Cdefine_symbol "caml_globals" :: - List.map (fun name -> Csymbol_address name) namelist @ + List.map mksym namelist @ [cint_zero]) let globals_map namelist = - Cdata(Cglobal_symbol "globals_map" :: - emit_constant "globals_map" + Cdata(Cglobal_symbol "caml_globals_map" :: + emit_constant "caml_globals_map" (Const_base (Const_string (Marshal.to_string namelist []))) []) (* Generate the master table of frame descriptors *) let frame_table namelist = + let mksym name = + Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "frametable")) + in Cdata(Cglobal_symbol "caml_frametable" :: Cdefine_symbol "caml_frametable" :: - List.map (fun name -> Csymbol_address(name ^ "__frametable")) namelist - @ [cint_zero]) + List.map mksym namelist + @ [cint_zero]) (* Generate the table of module data and code segments *) let segment_table namelist symbol begname endname = + let addsyms name lst = + Csymbol_address (Compilenv.make_symbol ~unitname:name (Some begname)) :: + Csymbol_address (Compilenv.make_symbol ~unitname:name (Some endname)) :: + lst + in 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]) + List.fold_right addsyms namelist [cint_zero]) let data_segment_table namelist = - segment_table namelist "caml_data_segments" "__data_begin" "__data_end" + 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" + 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)])) []) + let bucketname = "caml_bucket_" ^ name in + let symname = "caml_exn_" ^ name in + Cdata(Cglobal_symbol symname :: + emit_constant symname (Const_block(0,[Const_base(Const_string name)])) + [ Cglobal_symbol bucketname; + Cint(block_header 0 1); + Cdefine_symbol bucketname; + Csymbol_address symname ]) diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index c66e2270..49d90218 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -10,13 +10,14 @@ (* *) (***********************************************************************) -(* $Id: cmmgen.mli,v 1.11 2003/03/06 15:59:54 xleroy Exp $ *) +(* $Id: cmmgen.mli,v 1.12 2004/05/26 11:10:28 garrigue Exp $ *) (* Translation from closed lambda to C-- *) val compunit: int -> Clambda.ulambda -> Cmm.phrase list val apply_function: int -> Cmm.phrase +val send_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 diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 5508bed5..41504a19 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: compilenv.ml,v 1.18 2002/06/07 07:35:25 xleroy Exp $ *) +(* $Id: compilenv.ml,v 1.21 2004/05/26 11:10:28 garrigue Exp $ *) (* Compilation environments for compilation units *) @@ -43,6 +43,7 @@ type unit_infos = 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_send_fun: int list; (* Send functions needed *) mutable ui_force_link: bool } (* Always linked *) (* Each .a library has a matching .cmxa file that provides the following @@ -64,6 +65,7 @@ let current_unit = ui_approx = Value_unknown; ui_curry_fun = []; ui_apply_fun = []; + ui_send_fun = []; ui_force_link = false } let reset name = @@ -74,11 +76,18 @@ let reset name = current_unit.ui_imports_cmx <- []; current_unit.ui_curry_fun <- []; current_unit.ui_apply_fun <- []; + current_unit.ui_send_fun <- []; current_unit.ui_force_link <- false let current_unit_name () = current_unit.ui_name +let make_symbol ?(unitname = current_unit.ui_name) idopt = + let prefix = "caml" ^ unitname in + match idopt with + | None -> prefix + | Some id -> prefix ^ "__" ^ id + let read_unit_info filename = let ic = open_in_bin filename in try @@ -140,6 +149,10 @@ 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 +let need_send_fun n = + if not (List.mem n current_unit.ui_send_fun) then + current_unit.ui_send_fun <- n :: current_unit.ui_send_fun + (* Write the description of the current unit *) let write_unit_info info filename = diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 3f1b373c..3b3acb7c 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: compilenv.mli,v 1.12 2002/02/08 16:55:30 xleroy Exp $ *) +(* $Id: compilenv.mli,v 1.14 2004/05/26 11:10:28 garrigue Exp $ *) (* Compilation environments for compilation units *) @@ -34,6 +34,7 @@ type unit_infos = 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_send_fun: int list; (* Send functions needed *) mutable ui_force_link: bool } (* Always linked *) (* Each .a library has a matching .cmxa file that provides the following @@ -51,6 +52,13 @@ val reset: string -> unit val current_unit_name: unit -> string (* Return the name of the unit being compiled *) +val make_symbol: ?unitname:string -> string option -> string + (* [make_symbol ~unitname:u None] returns the asm symbol that + corresponds to the compilation unit [u] (default: the current unit). + [make_symbol ~unitname:u (Some id)] returns the asm symbol that + corresponds to symbol [id] in the compilation unit [u] + (or the current unit). *) + val global_approx: Ident.t -> Clambda.value_approximation (* Return the approximation for the given global identifier *) val set_global_approx: Clambda.value_approximation -> unit @@ -58,8 +66,9 @@ val set_global_approx: Clambda.value_approximation -> unit 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 need_send_fun: int -> unit + (* Record the need of a currying (resp. application, + message sending) function with the given arity *) val read_unit_info: string -> unit_infos * Digest.t (* Read infos and CRC from a [.cmx] file. *) diff --git a/asmcomp/hppa/emit.mlp b/asmcomp/hppa/emit.mlp index a2bc4383..012e75cf 100644 --- a/asmcomp/hppa/emit.mlp +++ b/asmcomp/hppa/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.14 2002/11/24 15:55:25 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.19 2004/05/16 09:09:23 xleroy Exp $ *) (* Emission of HP PA-RISC assembly code *) @@ -31,14 +31,6 @@ 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 @@ -66,29 +58,25 @@ let slot_offset loc cl = (* Output a label *) -let label_prefix = if hpux then "L$" else "L" - let emit_label lbl = - emit_string label_prefix; emit_int lbl + emit_string "L$"; 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 + 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" + | _ -> assert false (* 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 low_prefix = "RR%" +let high_prefix = "LR%" let is_immediate n = (n < 16) && (n >= -16) (* 5 bits *) @@ -99,19 +87,13 @@ 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}` + `RR%{emit_symbol s}-$global$` let load_symbol_high s = - if hpux - then ` addil LR'{emit_symbol s}-$global$, %r27\n` - else ` ldil L\`{emit_symbol s}, %r1\n` + ` addil LR%{emit_symbol s}-$global$, %r27\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` + ` addil LR%{emit_symbol s}-$global$+{emit_int ofs}, %r27\n` (* Record imported and defined symbols *) @@ -120,28 +102,27 @@ 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 + 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 + used_symbols := StringSet.add s !used_symbols; + called_symbols := StringSet.add s !called_symbols (* 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. *) + it is one of the caml_apply* caml_curry* caml_tuplify* special functions. *) + +let code_imports = ["caml_apply"; "caml_curry"; "caml_tuplify"] -let data_imports = - ["caml_globals_inited"; "nativeint_ops"; "int32_ops"; "int64_ops"] +let match_prefix s pref = + String.length s >= String.length pref + && String.sub s 0 (String.length pref) = pref 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) + if StringSet.mem s !called_symbols + || List.exists (match_prefix s) code_imports then `, code\n` else `, data\n` end @@ -166,8 +147,8 @@ let emit_load instr addr arg dst = 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; + load_symbol_offset_high s ofs; ` {emit_string instr} {emit_symbol_low s}+{emit_int ofs}(%r1), {emit_reg dst}\n` | Iindexed ofs -> if is_offset ofs then @@ -265,14 +246,10 @@ let emit_float_store addr arg src doubleword = ` 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 *) +(* Output an align directive. *) let emit_align n = - if hpux - then ` .align {emit_int n}\n` - else ` .align {emit_int(Misc.log2 n)}\n` + ` .align {emit_int n}\n` (* Record live pointers at call points *) @@ -314,35 +291,17 @@ let emit_frame fd = let float_constants = ref ([] : (int * string) list) -let emit_float_constant (lbl, cst) = - if hpux then begin +let emit_float_constants () = + if Config.system = "hpux" then begin ` .space $TEXT$\n`; ` .subspa $LIT$\n` end else - ` .literal8\n`; + ` .text\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 + List.iter + (fun (lbl, cst) -> `{emit_label lbl}: .double {emit_string cst}\n`) + !float_constants; + float_constants := [] (* Describe the registers used to pass arguments to a C function *) @@ -363,16 +322,8 @@ let describe_call arg = (* 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 + call_symbol s; + ` bl {emit_symbol s}, {emit_string retreg}\n` (* Names of various instructions *) @@ -382,14 +333,14 @@ let name_for_int_operation = function | Iand -> "and" | Ior -> "or" | Ixor -> "xor" - | _ -> Misc.fatal_error "Emit.name_for_int_operation" + | _ -> assert false 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" + | _ -> assert false let name_for_specific_operation = function Ishift1add -> "sh1add" @@ -464,7 +415,7 @@ let rec emit_instr i dslot = ` fldds 0(%r1), {emit_reg dst}\n` end | (_, _) -> - fatal_error "Emit: Imove" + assert false end | Lop(Iconst_int n) -> if is_offset_native n then @@ -508,21 +459,15 @@ let rec emit_instr i dslot = else ` ldo {emit_int(-n)}(%r30), %r30\n` end | Lop(Iextcall(s, alloc)) -> + call_symbol s; 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; + ` 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 *) record_frame i.live end else begin - if hpux then describe_call i.arg; + describe_call i.arg; emit_call s "%r2"; fill_delay_slot dslot end @@ -579,11 +524,11 @@ let rec emit_instr i dslot = ` addi 4, %r3, {emit_reg i.res.(0)}\n`; `{emit_label lbl_cont}:\n` end else begin - emit_call "caml_alloc" "%r2"; + emit_call "caml_allocN" "%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 *) + ` addi 4, %r3, {emit_reg i.res.(0)}\n` end | Lop(Iintop Imul) -> ` stws,ma {emit_reg i.arg.(0)}, 8(%r30)\n`; @@ -595,21 +540,11 @@ let rec emit_instr i dslot = ` 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; + ` bl $$divI, %r31\n`; 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; + ` bl $$remI, %r31\n`; fill_delay_slot dslot | Lop(Iintop Ilsl) -> ` subi 31, {emit_reg i.arg.(1)}, %r1\n`; @@ -640,13 +575,19 @@ let rec emit_instr i dslot = | 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`; + if not (l = 0) then + ` zdepi -1, 31, {emit_int l}, %r1\n` + else + ` xor %r1, %r1, %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`; + if not (l = 0) then + ` zdepi -1, 31, {emit_int l}, %r1\n` + else + ` xor %r1, %r1, %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` @@ -668,7 +609,7 @@ let rec emit_instr i dslot = ` 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" + assert false | 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` @@ -939,7 +880,7 @@ let fixup_cond_branches funbody = the code positions. *) displ < -1843 || displ > 1842 with Not_found -> - fatal_error "Emit_hppa.long_branch" in + assert false in let rec fix_branches pos i = match i.desc with Lend -> () @@ -969,7 +910,8 @@ let fundecl fundecl = define_symbol fundecl.fun_name; range_check_trap := 0; let n = frame_size() in - if hpux then begin + begin match Config.system with + | "hpux" -> ` .code\n`; ` .align 4\n`; ` .export {emit_symbol fundecl.fun_name}, entry, priv_lev=3\n`; @@ -980,11 +922,13 @@ let fundecl fundecl = else ` .callinfo frame={emit_int n}, no_calls\n`; ` .entry\n` - end else begin + | "linux" -> ` .text\n`; - ` .align 2\n`; + ` .align 8\n`; ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n` + | _ -> + assert false end; if !contains_calls then ` stwm %r2, {emit_int n}(%r30)\n` @@ -994,25 +938,20 @@ let fundecl fundecl = 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 + emit_call "caml_ml_array_bound_error" "%r31"; + ` nop\n` end; - if hpux then begin + if Config.system = "hpux"then begin ` .exit\n`; ` .procend\n` end; - List.iter emit_float_constant !float_constants + emit_float_constants() (* Emission of data *) let declare_global s = define_symbol s; - if hpux + if Config.system = "hpux" then ` .export {emit_symbol s}, data\n` else ` .globl {emit_symbol s}\n` @@ -1037,8 +976,7 @@ let emit_item = function | 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`; + use_symbol s; ` .long {emit_symbol s}\n` | Clabel_address lbl -> ` .long {emit_label(lbl + 100000)}\n` @@ -1046,8 +984,9 @@ let emit_item = function 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` + if Config.system = "hpux" + then ` .block {emit_int n}\n` + else ` .space {emit_int n}\n` | Calign n -> emit_align n @@ -1058,7 +997,7 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = - if hpux then begin + if Config.system = "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`; @@ -1072,32 +1011,30 @@ let begin_assembly() = 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 + let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; - emit_global lbl_begin; + declare_global lbl_begin; `{emit_symbol lbl_begin}:\n`; - let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ` .code\n`; - emit_global lbl_begin; + declare_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; + let lbl_end = Compilenv.make_symbol (Some "code_end") in + declare_global lbl_end; `{emit_symbol lbl_end}:\n`; ` .data\n`; - let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in - emit_global lbl_end; + let lbl_end = Compilenv.make_symbol (Some "data_end") in + declare_global lbl_end; `{emit_symbol lbl_end}:\n`; ` .long 0\n`; - let lbl = Compilenv.current_unit_name() ^ "__frametable" in - emit_global lbl; + let lbl = Compilenv.make_symbol (Some "frametable") in + declare_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() + emit_imports() diff --git a/asmcomp/hppa/proc.ml b/asmcomp/hppa/proc.ml index e53643a3..58b07743 100644 --- a/asmcomp/hppa/proc.ml +++ b/asmcomp/hppa/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.6 2002/07/22 16:37:49 doligez Exp $ *) +(* $Id: proc.ml,v 1.7 2004/05/09 15:19:16 xleroy Exp $ *) (* Description of the HP PA-RISC processor *) @@ -217,7 +217,7 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("gas -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command ("as -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 6534e38d..c2b4e017 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.29 2003/08/22 14:05:03 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.32 2004/05/03 12:46:50 xleroy Exp $ *) (* Emission of Intel 386 assembly code *) @@ -399,12 +399,16 @@ let emit_instr fallthrough i = 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 + begin match Int64.bits_of_float (float_of_string s) with + | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` - else if f = 1.0 then + | 0x8000_0000_0000_0000L -> (* -0.0 *) + ` fldz\n fchs\n` + | 0x3FF0_0000_0000_0000L -> (* 1.0 *) ` fld1\n` - else begin + | 0xBFF0_0000_0000_0000L -> (* -1.0 *) + ` fld1\n fchs\n` + | _ -> let lbl = new_label() in float_constants := (lbl, s) :: !float_constants; ` fldl {emit_label lbl}\n` @@ -484,10 +488,10 @@ let emit_instr fallthrough i = | 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`; + `{emit_label lbl_redo}: movl {emit_symbol "caml_young_ptr"}, %eax\n`; ` subl ${emit_int n}, %eax\n`; - ` movl %eax, {emit_symbol "young_ptr"}\n`; - ` cmpl {emit_symbol "young_limit"}, %eax\n`; + ` movl %eax, {emit_symbol "caml_young_ptr"}\n`; + ` cmpl {emit_symbol "caml_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`; @@ -502,7 +506,7 @@ let emit_instr fallthrough i = | 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` + ` call {emit_symbol "caml_allocN"}\n` end; `{record_frame i.live} leal 4(%eax), {emit_reg i.res.(0)}\n` end @@ -808,7 +812,7 @@ let fundecl fundecl = 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`; + `{emit_label !range_check_trap}: call {emit_symbol "caml_ml_array_bound_error"}\n`; (* Never returns, but useful to have retaddr on stack for debugging *) List.iter emit_float_constant !float_constants @@ -853,26 +857,26 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = - let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl = Compilenv.make_symbol (Some "frametable") in ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; ` .long {emit_int (List.length !frame_descriptors)}\n`; diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index 79730ca8..2f025f11 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit_nt.mlp,v 1.21 2003/06/30 15:39:38 xleroy Exp $ *) +(* $Id: emit_nt.mlp,v 1.24 2004/05/03 12:46:50 xleroy Exp $ *) (* Emission of Intel 386 assembly code, MASM syntax. *) @@ -372,12 +372,16 @@ let emit_instr i = 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 + begin match Int64.bits_of_float (float_of_string s) with + | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` - else if f = 1.0 then + | 0x8000_0000_0000_0000L -> (* -0.0 *) + ` fldz\n fchs\n` + | 0x3FF0_0000_0000_0000L -> (* 1.0 *) ` fld1\n` - else begin + | 0xBFF0_0000_0000_0000L -> (* -1.0 *) + ` fld1\n fchs\n` + | _ -> let lbl = new_label() in float_constants := (lbl, s) :: !float_constants; ` fld {emit_label lbl}\n` @@ -461,10 +465,10 @@ let emit_instr i = | Lop(Ialloc n) -> if !fastcode_flag then begin let lbl_redo = new_label() in - `{emit_label lbl_redo}: mov eax, _young_ptr\n`; + `{emit_label lbl_redo}: mov eax, _caml_young_ptr\n`; ` sub eax, {emit_int n}\n`; - ` mov _young_ptr, eax\n`; - ` cmp eax, _young_limit\n`; + ` mov _caml_young_ptr, eax\n`; + ` cmp eax, _caml_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`; @@ -479,7 +483,7 @@ let emit_instr i = | 12 -> ` call _caml_alloc2\n` | 16 -> ` call _caml_alloc3\n` | _ -> ` mov eax, {emit_int n}\n`; - ` call _caml_alloc\n` + ` call _caml_allocN\n` end; `{record_frame i.live} lea {emit_reg i.res.(0)}, [eax+4]\n` end @@ -764,7 +768,7 @@ let fundecl fundecl = 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`; + `{emit_label !range_check_trap}: jmp _caml_ml_array_bound_error\n`; begin match !float_constants with [] -> () | _ -> @@ -816,39 +820,39 @@ let data l = let begin_assembly() = `.386\n`; ` .MODEL FLAT\n\n`; - ` EXTERN _young_ptr: DWORD\n`; - ` EXTERN _young_limit: DWORD\n`; + ` EXTERN _caml_young_ptr: DWORD\n`; + ` EXTERN _caml_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_allocN: PROC\n`; ` EXTERN _caml_alloc1: PROC\n`; ` EXTERN _caml_alloc2: PROC\n`; ` EXTERN _caml_alloc3: PROC\n`; - ` EXTERN _caml_array_bound_error: PROC\n`; + ` EXTERN _caml_ml_array_bound_error: PROC\n`; ` .DATA\n`; - let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl = Compilenv.make_symbol (Some "frametable") in add_def_symbol lbl; ` PUBLIC {emit_symbol lbl}\n`; `{emit_symbol lbl} DWORD {emit_int (List.length !frame_descriptors)}\n`; diff --git a/asmcomp/ia64/emit.mlp b/asmcomp/ia64/emit.mlp index 53b4af4a..83c87aef 100644 --- a/asmcomp/ia64/emit.mlp +++ b/asmcomp/ia64/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.13 2002/11/24 15:55:25 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.16 2004/05/03 12:46:51 xleroy Exp $ *) (* Emission of IA64 assembly code *) @@ -819,15 +819,15 @@ let emit_instr i = if is_immediate_addl_nat n then "movi" else "movil" in insimm instr [||] (Nativeint.to_string n) (regs i.res) | Lop(Iconst_float s) -> - 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) + begin match Int64.bits_of_float (float_of_string s) with + | 0x0000_0000_0000_0000L -> (* +0.0 *) + insert "mov" [| "f0" |] (regs i.res) + | 0x3FF0_0000_0000_0000L -> (* 1.0 *) + insert "mov" [| "f1" |] (regs i.res) + | _ -> + 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); @@ -935,7 +935,7 @@ let emit_instr i = insimm "addi" [| "r4" |] "8" (regs i.res) end else begin insimm "movi" [||] (string_of_int n) [| "r2" |]; - insimm "brcall" [||] "caml_alloc#" [| "b0" |]; + insimm "brcall" [||] "caml_allocN#" [| "b0" |]; end_basic_block(); `{record_frame i.live}\n`; insimm "addi" [| "r4" |] "8" (regs i.res) @@ -954,7 +954,7 @@ let emit_instr i = 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#" + insimm "brcallcondexc" [| "p6" |] "caml_ml_array_bound_error#" [| "b0"; "heap" |] | Lop(Iintop op) -> let instr = name_for_int_operation op in @@ -1024,7 +1024,7 @@ let emit_instr i = 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#" + insimm "brcallcondexc" [| "p6" |] "caml_ml_array_bound_error#" [| "b0"; "heap" |] | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op ^ "i" in @@ -1309,18 +1309,18 @@ let data l = let begin_assembly() = ` .data\n`; - emit_define_symbol (Compilenv.current_unit_name() ^ "__data_begin"); + emit_define_symbol (Compilenv.make_symbol (Some "data_begin")); ` .text\n`; - emit_define_symbol (Compilenv.current_unit_name() ^ "__code_begin") + emit_define_symbol (Compilenv.make_symbol (Some "code_begin")) let end_assembly () = ` .data\n`; - emit_define_symbol (Compilenv.current_unit_name() ^ "__data_end"); + emit_define_symbol (Compilenv.make_symbol (Some "data_end")); ` .text\n`; - emit_define_symbol (Compilenv.current_unit_name() ^ "__code_end"); + emit_define_symbol (Compilenv.make_symbol (Some "code_end")); ` .rodata\n`; ` .align 8\n`; - emit_define_symbol (Compilenv.current_unit_name() ^ "__frametable"); + emit_define_symbol (Compilenv.make_symbol (Some "frametable")); ` data8 {emit_int (List.length !frame_descriptors)}\n`; List.iter emit_frame !frame_descriptors; frame_descriptors := [] diff --git a/asmcomp/ia64/selection.ml b/asmcomp/ia64/selection.ml index 0a883c78..3944eb1c 100644 --- a/asmcomp/ia64/selection.ml +++ b/asmcomp/ia64/selection.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selection.ml,v 1.6 2003/08/05 13:39:03 xleroy Exp $ *) +(* $Id: selection.ml,v 1.7 2004/05/03 12:27:07 xleroy Exp $ *) (* Instruction selection for the IA64 processor *) @@ -108,7 +108,7 @@ method select_operation op args = (Iintop_imm(Idiv, n), [arg]) | (Cdivi, _) -> (Iextcall("__divdi3", false), args) - | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> + | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) && n <> 1 -> (Iintop_imm(Imod, n), [arg]) | (Cmodi, _) -> (Iextcall("__moddi3", false), args) diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index 2d84191b..5e0ab8a6 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -10,73 +10,36 @@ (* *) (***********************************************************************) -(* $Id: interf.ml,v 1.13 2001/09/11 15:30:38 xleroy Exp $ *) +(* $Id: interf.ml,v 1.14 2004/05/08 15:04:03 xleroy Exp $ *) (* Construction of the interference graph. Annotate pseudoregs with interference lists and preference lists. *) +module IntPairSet = + Set.Make(struct type t = int * int let compare = compare end) + 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 *) + - by a sparse bit matrix (a set of pairs of register stamps) *) - let mat = BitMatrix.create 6 in + let mat = ref IntPairSet.empty 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 + if i <> j then begin + let p = if i < j then (i, j) else (j, i) in + if not(IntPairSet.mem p !mat) then begin + mat := IntPairSet.add p !mat; + if ri.loc = Unknown then ri.interf <- rj :: ri.interf; + if rj.loc = Unknown then rj.interf <- ri :: rj.interf + end end in (* Record interferences between a register array and a set of registers *) @@ -148,7 +111,8 @@ let build_graph fundecl = let i = r1.stamp and j = r2.stamp in if i <> j && r1.loc = Unknown - && not (BitMatrix.isset mat i j) + && (let p = if i < j then (i, j) else (j, i) in + not (IntPairSet.mem p !mat)) then r1.prefer <- (r2, weight) :: r1.prefer end in diff --git a/asmcomp/mips/emit.mlp b/asmcomp/mips/emit.mlp index c967ad79..a67d7fed 100644 --- a/asmcomp/mips/emit.mlp +++ b/asmcomp/mips/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.16 2003/04/25 12:26:59 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.18 2004/01/05 20:25:56 doligez Exp $ *) (* Emission of Mips assembly code *) @@ -504,7 +504,7 @@ let fundecl fundecl = end; if !range_check_trap > 0 then begin `{emit_label !range_check_trap}:\n`; - ` la $25, caml_array_bound_error\n`; + ` la $25, caml_ml_array_bound_error\n`; ` j $25\n` end; ` .end {emit_symbol fundecl.fun_name}\n` @@ -562,11 +562,11 @@ let begin_assembly() = ` .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 + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ` .text\n`; ` .globl {emit_symbol lbl_begin}\n`; ` .ent {emit_symbol lbl_begin}\n`; @@ -574,18 +574,18 @@ let begin_assembly() = ` .end {emit_symbol lbl_begin}\n` let end_assembly () = - let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl = Compilenv.make_symbol (Some "frametable") in ` .rdata\n`; ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 191fb3ce..46d10816 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: arch.ml,v 1.10 2003/07/17 15:11:02 xleroy Exp $ *) +(* $Id: arch.ml,v 1.11 2004/06/19 16:13:32 xleroy Exp $ *) (* Specific operations for the PowerPC processor *) @@ -51,7 +51,7 @@ 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" + | Iindexed2 -> assert false let num_args_addressing = function Ibased(s, n) -> 0 @@ -82,20 +82,3 @@ let print_specific_operation printreg op ppf arg = | 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 index 1ec44002..26096777 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.17 2003/07/17 15:11:02 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.21 2004/06/19 17:39:34 xleroy Exp $ *) (* Emission of PowerPC assembly code *) @@ -26,27 +26,12 @@ 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 +(* Layout of the stack. The stack is kept 16-aligned. *) 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 *) @@ -56,8 +41,8 @@ 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 + then !stack_offset + num_stack_slots.(1) * 8 + n * 4 + else !stack_offset + n * 8 | Incoming n -> frame_size() + n | Outgoing n -> n @@ -65,19 +50,14 @@ let slot_offset loc cls = let emit_symbol = match Config.system with - "aix" | "elf" | "bsd" -> (fun s -> Emitaux.emit_symbol '.' s) + | "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 @@ -89,23 +69,20 @@ let emit_label lbl = let data_space = match Config.system with - "aix" -> " .csect .data[RW]\n" | "elf" | "bsd" -> " .section \".data\"\n" - | "rhapsody" -> " .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" + | "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" + | "rhapsody" -> " .const\n" | _ -> assert false (* Output a pseudo-register *) @@ -152,12 +129,11 @@ let is_immediate n = 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) *) +(* Output a "upper 16 bits" or "lower 16 bits" operator. *) let emit_upper emit_fun arg = match Config.system with - "elf" | "bsd" -> + | "elf" | "bsd" -> emit_fun arg; emit_string "@ha" | "rhapsody" -> emit_string "ha16("; emit_fun arg; emit_string ")" @@ -165,7 +141,7 @@ let emit_upper emit_fun arg = let emit_lower emit_fun arg = match Config.system with - "elf" | "bsd" -> + | "elf" | "bsd" -> emit_fun arg; emit_string "@l" | "rhapsody" -> emit_string "lo16("; emit_fun arg; emit_string ")" @@ -181,7 +157,6 @@ let emit_symbol_offset (s, 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 -> @@ -247,47 +222,12 @@ let emit_frame fd = 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) *) +(* Record floating-point literals *) let float_literals = ref ([] : (string * int) list) (* Record external C functions to be called in a position-independent way - (for Rhapsody) *) + (for MacOSX) *) let pic_externals = (Config.system = "rhapsody") @@ -315,7 +255,7 @@ let name_for_int_comparison = function let name_for_intop = function Iadd -> "add" | Imul -> "mullw" - | Idiv -> if powerpc then "divw" else "divs" + | Idiv -> "divw" | Iand -> "and" | Ior -> "or" | Ixor -> "xor" @@ -378,17 +318,13 @@ 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(Iconst_float s) -> 2 + | Lop(Iconst_symbol s) -> 2 + | Lop(Icall_ind) -> 2 + | Lop(Icall_imm s) -> 1 + | Lop(Itailcall_ind) -> 5 + | Lop(Itailcall_imm s) -> if s = !function_name then 1 else 4 + | Lop(Iextcall(s, true)) -> 3 | Lop(Iextcall(s, false)) -> if pic_externals then 4 else 1 | Lop(Istackoffset n) -> 1 | Lop(Iload(chunk, addr)) -> @@ -398,7 +334,7 @@ let instr_size = function | 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 Imod) -> 3 | Lop(Iintop(Icomp cmp)) -> 4 | Lop(Iintop op) -> 1 | Lop(Iintop_imm(Idiv, n)) -> 2 @@ -420,9 +356,9 @@ let instr_size = function + (if lbl2 = None then 0 else 1) | Lswitch jumptbl -> 8 | Lsetuptrap lbl -> 1 - | Lpushtrap -> if toc then 5 else 4 + | Lpushtrap -> 4 | Lpoptrap -> 2 - | Lraise -> if toc then 7 else 6 + | Lraise -> 6 let label_map code = let map = Hashtbl.create 37 in @@ -526,52 +462,23 @@ let rec emit_instr i dslot = ` 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 + 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` | 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 + ` 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` | 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 + ` mtctr {emit_reg i.arg.(0)}\n`; + record_frame i.live; + ` bctrl\n` | 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 *) + ` bl {emit_symbol s}\n` | 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; + ` mtctr {emit_reg i.arg.(0)}\n`; 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`; @@ -584,7 +491,7 @@ let rec emit_instr i dslot = | 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 + else begin let n = frame_size() in if !contains_calls then begin ` lwz {emit_gpr 11}, {emit_int(n - 4)}({emit_gpr 1})\n`; @@ -594,38 +501,11 @@ let rec emit_instr i dslot = 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` + ` b {emit_symbol s}\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 + 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` @@ -634,19 +514,17 @@ let rec emit_instr i dslot = ` 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` + ` bl {emit_symbol "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` + ` mtctr {emit_gpr 11}\n`; + ` bctrl\n` end else - ` bl {emit_codesymbol s}\n` - end; - if toc then - ` cror 31, 31, 31\n` (* nop *) + ` bl {emit_symbol s}\n` + end | Lop(Istackoffset n) -> ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int (-n)}\n`; stack_offset := !stack_offset + n @@ -688,18 +566,12 @@ let rec emit_instr i dslot = 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. *) + | Lop(Iintop Isub) -> (* subfc has swapped arguments *) ` 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 + ` 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` | Lop(Iintop(Icomp cmp)) -> begin match cmp with Isigned c -> @@ -747,17 +619,11 @@ let rec emit_instr i dslot = 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; + let lbl = new_label() in + float_literals := ("4.503601774854144e15", lbl) :: !float_literals; + (* That float above 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`; ` 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`; @@ -849,12 +715,8 @@ let rec emit_instr i dslot = 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; + ` 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`; ` 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`; @@ -868,25 +730,21 @@ let rec emit_instr i dslot = | Lsetuptrap lbl -> ` bl {emit_label lbl}\n` | Lpushtrap -> - stack_offset := !stack_offset + trap_frame_size; + stack_offset := !stack_offset + 16; ` mflr {emit_gpr 0}\n`; - ` stwu {emit_gpr 0}, -{emit_int trap_frame_size}({emit_gpr 1})\n`; + ` stwu {emit_gpr 0}, -16({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 + ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; + stack_offset := !stack_offset - 16 | 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`; + ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; ` blr\n` and emit_delay = function @@ -946,18 +804,13 @@ let fundecl fundecl = 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`; + `{emit_symbol fundecl.fun_name}:\n`; let n = frame_size() in if !contains_calls then begin ` mflr {emit_gpr 0}\n`; @@ -973,14 +826,7 @@ let fundecl fundecl = (* 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 + ` b {emit_symbol "caml_call_gc"}\n` end; (* Emit the floating-point literals *) if !float_literals <> [] then begin @@ -1036,19 +882,17 @@ let data 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 + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in emit_string code_space; declare_global_data lbl_begin; `{emit_symbol lbl_begin}:\n` @@ -1056,42 +900,29 @@ let begin_assembly() = 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`; + `{emit_label !lbl_jumptbl}:\n`; List.iter - (fun lbl -> ` .long {emit_label lbl} - {emit_label lbl_tbl}\n`) + (fun lbl -> ` .long {emit_label lbl} - {emit_label !lbl_jumptbl}\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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl = Compilenv.make_symbol (Some "frametable") in declare_global_data lbl; `{emit_symbol lbl}:\n`; ` .long {emit_int (List.length !frame_descriptors)}\n`; diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 573169ee..b17c9f6e 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.10 2003/07/17 15:11:02 xleroy Exp $ *) +(* $Id: proc.ml,v 1.12 2004/06/19 17:39:35 xleroy Exp $ *) (* Description of the Power PC *) @@ -128,11 +128,8 @@ let calling_conventions 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. *) + (loc, Misc.align !ofs 16) + (* Keep stack 16-aligned. *) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs @@ -189,7 +186,7 @@ let poweropen_external_conventions first_int last_int let loc_external_arguments = match Config.system with - "aix" | "rhapsody" -> poweropen_external_conventions 0 7 100 112 + | "rhapsody" -> poweropen_external_conventions 0 7 100 112 | "elf" | "bsd" -> calling_conventions 0 7 100 107 outgoing 8 | _ -> assert false @@ -239,9 +236,6 @@ 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" -> diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml index 4674bde0..7e760197 100644 --- a/asmcomp/power/scheduling.ml +++ b/asmcomp/power/scheduling.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: scheduling.ml,v 1.5 1999/11/17 18:56:46 xleroy Exp $ *) +(* $Id: scheduling.ml,v 1.6 2004/06/19 16:13:33 xleroy Exp $ *) (* Instruction scheduling for the Power PC *) @@ -27,7 +27,7 @@ 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 + | Iconst_symbol _ -> 1 | Iintop Imul -> 9 | Iintop_imm(Imul, _) -> 5 | Iintop(Idiv | Imod) -> 36 @@ -44,7 +44,7 @@ method reload_retaddr_latency = 12 (* Issue cycles. Rough approximations. *) method oper_issue_cycles = function - Iconst_float _ | Iconst_symbol _ -> if toc then 1 else 2 + Iconst_float _ | Iconst_symbol _ -> 2 | Iload(_, Ibased(_, _)) -> 2 | Istore(_, Ibased(_, _)) -> 2 | Ialloc _ -> 4 diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index 495db6c1..141d348a 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selection.ml,v 1.5 2000/12/28 13:03:01 weis Exp $ *) +(* $Id: selection.ml,v 1.6 2004/06/19 16:13:33 xleroy Exp $ *) (* Instruction selection for the Power PC processor *) @@ -28,8 +28,7 @@ type addressing_expr = | 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 *) + Cconst_symbol s -> (Asymbol s, 0) | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> let (a, n) = select_addr arg in (a, n + m) @@ -81,9 +80,6 @@ method select_operation op args = | (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]) diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index 32b079f0..28d80948 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.19 2003/09/04 12:31:08 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.21 2004/01/05 20:25:56 doligez Exp $ *) (* Emission of Sparc assembly code *) @@ -404,7 +404,7 @@ let rec emit_instr i dslot = ` 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`; + `{record_frame i.live} call {emit_symbol "caml_allocN"}\n`; ` mov {emit_int n}, %g2\n`; (* in delay slot *) ` add %l6, 4, {emit_reg i.res.(0)}\n` end @@ -721,26 +721,26 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = - let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_begin = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl_end = Compilenv.make_symbol (Some "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 + let lbl = Compilenv.make_symbol (Some "frametable") in rodata (); ` .global {emit_symbol lbl}\n`; if Config.system = "solaris" then diff --git a/asmrun/.depend b/asmrun/.depend index 63c99b5b..0f46b91e 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -106,9 +106,10 @@ memory.o: memory.c ../byterun/fail.h ../byterun/misc.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 + ../byterun/fix_code.h ../byterun/interp.h ../byterun/intext.h \ + ../byterun/io.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 \ @@ -120,8 +121,9 @@ misc.o: misc.c ../byterun/config.h ../config/m.h ../config/s.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 + ../byterun/gc.h ../byterun/interp.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 \ @@ -272,9 +274,10 @@ memory.d.o: memory.c ../byterun/fail.h ../byterun/misc.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 + ../byterun/fix_code.h ../byterun/interp.h ../byterun/intext.h \ + ../byterun/io.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 \ @@ -286,8 +289,9 @@ misc.d.o: misc.c ../byterun/config.h ../config/m.h ../config/s.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 + ../byterun/gc.h ../byterun/interp.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 \ @@ -438,9 +442,10 @@ memory.p.o: memory.c ../byterun/fail.h ../byterun/misc.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 + ../byterun/fix_code.h ../byterun/interp.h ../byterun/intext.h \ + ../byterun/io.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 \ @@ -452,8 +457,9 @@ misc.p.o: misc.c ../byterun/config.h ../config/m.h ../config/s.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 + ../byterun/gc.h ../byterun/interp.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 \ diff --git a/asmrun/Makefile b/asmrun/Makefile index fbd8b728..629d0394 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -11,12 +11,13 @@ # # ######################################################################### -# $Id: Makefile,v 1.49 2002/03/11 10:12:43 xleroy Exp $ +# $Id: Makefile,v 1.51 2004/05/09 15:19:16 xleroy Exp $ include ../config/Makefile CC=$(NATIVECC) -FLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) +FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \ + -DTARGET_$(ARCH) -DSYS_$(SYSTEM) CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) @@ -149,13 +150,6 @@ LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.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: diff --git a/asmrun/alpha.S b/asmrun/alpha.S index 22a3fbfa..1aa3a86d 100644 --- a/asmrun/alpha.S +++ b/asmrun/alpha.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: alpha.S,v 1.25 2002/09/20 11:40:28 xleroy Exp $ */ +/* $Id: alpha.S,v 1.29 2004/01/03 12:51:18 doligez Exp $ */ /* Asm part of the runtime system, Alpha processor */ @@ -20,7 +20,7 @@ .text .globl caml_alloc2 .globl caml_alloc3 - .globl caml_alloc + .globl caml_allocN .globl caml_call_gc /* Note: the profiling code sets $27 to the address of the "normal" entrypoint. @@ -68,10 +68,10 @@ $102: ldiq $25, 32 br $110 .end caml_alloc3 - .globl caml_alloc - .ent caml_alloc + .globl caml_allocN + .ent caml_allocN .align 3 -caml_alloc: +caml_allocN: .prologue 0 subq $13, $25, $13 .set noat @@ -79,7 +79,7 @@ caml_alloc: bne $at, $110 .set at ret ($26) - .end caml_alloc + .end caml_allocN .globl caml_call_gc .ent caml_call_gc @@ -102,7 +102,7 @@ $103: ldgp $gp, 0($27) lda $24, 0x100($sp) stq $24, caml_gc_regs /* Save current allocation pointer for debugging purposes */ -$113: stq $13, young_ptr +$113: stq $13, caml_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 */ @@ -150,7 +150,7 @@ $113: stq $13, young_ptr stt $f29, 29 * 8 ($sp) stt $f30, 30 * 8 ($sp) /* Call the garbage collector */ - jsr garbage_collection + jsr caml_garbage_collection ldgp $gp, 0($26) /* Restore all regs used by the code generator */ lda $24, 0x100($sp) @@ -197,8 +197,8 @@ $113: stq $13, young_ptr 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 + ldq $13, caml_young_ptr + ldq $14, caml_young_limit /* Allocate space for the block */ ldq $25, 0x1E8($sp) subq $13, $25, $13 @@ -233,16 +233,16 @@ $104: ldgp $gp, 0($27) 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 + lda $12, caml_young_ptr stq $13, 0($12) - lda $14, young_limit + lda $14, caml_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 */ + ldq $13, 0($12) /* $12 still points to caml_young_ptr */ + ldq $14, 0($14) /* $14 still points to caml_young_limit */ /* Say that we are back into Caml code */ stq $31, 0($11) /* $11 still points to caml_last_return_address */ /* Restore $gp */ @@ -261,7 +261,7 @@ caml_start_program: ldgp $gp, 0($27) lda $25, caml_program -/* Code shared with callback* */ +/* Code shared with caml_callback* */ $107: /* Save return address */ lda $sp, -128($sp) @@ -298,8 +298,8 @@ $107: stq $0, 8($sp) mov $sp, $15 /* Reload allocation pointers */ - ldq $13, young_ptr - ldq $14, young_limit + ldq $13, caml_young_ptr + ldq $14, caml_young_limit /* We are back into Caml code */ stq $31, caml_last_return_address /* Call the Caml code */ @@ -321,7 +321,7 @@ $112: ldq $24, 0($sp) stq $24, caml_gc_regs lda $sp, 32($sp) /* Update allocation pointer */ - stq $13, young_ptr + stq $13, caml_young_ptr /* Reload callee-save registers */ ldq $9, 8($sp) ldq $10, 16($sp) @@ -356,28 +356,28 @@ $109: ldgp $gp, 0($26) /* Raise an exception from C */ - .globl raise_caml_exception - .ent raise_caml_exception + .globl caml_raise_exception + .ent caml_raise_exception .align 3 -raise_caml_exception: +caml_raise_exception: ldgp $gp, 0($27) mov $16, $0 /* Move exn bucket */ - ldq $13, young_ptr - ldq $14, young_limit + ldq $13, caml_young_ptr + ldq $14, caml_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 + .end caml_raise_exception /* Callback from C to Caml */ - .globl callback_exn - .ent callback_exn + .globl caml_callback_exn + .ent caml_callback_exn .align 3 -callback_exn: +caml_callback_exn: /* Initial shuffling of arguments */ ldgp $gp, 0($27) mov $16, $25 @@ -385,12 +385,12 @@ callback_exn: mov $25, $17 /* environment */ ldq $25, 0($25) /* code pointer */ br $107 - .end callback_exn + .end caml_callback_exn - .globl callback2_exn - .ent callback2_exn + .globl caml_callback2_exn + .ent caml_callback2_exn .align 3 -callback2_exn: +caml_callback2_exn: ldgp $gp, 0($27) mov $16, $25 mov $17, $16 /* first arg */ @@ -398,12 +398,12 @@ callback2_exn: mov $25, $18 /* environment */ lda $25, caml_apply2 br $107 - .end callback2_exn + .end caml_callback2_exn - .globl callback3_exn - .ent callback3_exn + .globl caml_callback3_exn + .ent caml_callback3_exn .align 3 -callback3_exn: +caml_callback3_exn: ldgp $gp, 0($27) mov $16, $25 mov $17, $16 /* first arg */ @@ -412,27 +412,27 @@ callback3_exn: mov $25, $19 /* environment */ lda $25, caml_apply3 br $107 - .end callback3_exn + .end caml_callback3_exn -/* Glue code to call array_bound_error */ +/* Glue code to call [caml_array_bound_error] */ - .globl caml_array_bound_error - .ent caml_array_bound_error + .globl caml_ml_array_bound_error + .ent caml_ml_array_bound_error .align 3 -caml_array_bound_error: +caml_ml_array_bound_error: br $27, $111 $111: ldgp $gp, 0($27) - lda $25, array_bound_error + lda $25, caml_array_bound_error br caml_c_call /* never returns */ - .end caml_array_bound_error + .end caml_ml_array_bound_error #if defined(SYS_digital) .rdata #else .section .rodata #endif - .globl system__frametable -system__frametable: + .globl caml_system__frametable +caml_system__frametable: .quad 1 /* one descriptor */ .quad $108 + 4 /* return address into callback */ .word -1 /* negative frame size => use callback link */ diff --git a/asmrun/amd64.S b/asmrun/amd64.S index 5baf21d2..85f15c86 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: amd64.S,v 1.1 2003/06/30 08:28:45 xleroy Exp $ */ +/* $Id: amd64.S,v 1.8.4.1 2004/07/01 16:09:03 xleroy Exp $ */ /* Asm part of the runtime system, AMD64 processor */ /* Must be preprocessed by cpp */ @@ -34,11 +34,11 @@ FUNCTION(caml_call_gc) 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) +.L105: + /* Save caml_young_ptr, caml_exception_pointer */ + movq %r15, caml_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 @@ -72,7 +72,7 @@ FUNCTION(caml_call_gc) movlpd %xmm14, 14*8(%rsp) movlpd %xmm15, 15*8(%rsp) /* Call the garbage collector */ - call garbage_collection + call caml_garbage_collection /* Restore all regs used by the code generator */ movlpd 0*8(%rsp), %xmm0 movlpd 1*8(%rsp), %xmm1 @@ -104,15 +104,15 @@ FUNCTION(caml_call_gc) popq %rbp popq %r12 popq %r13 - /* Restore young_ptr, caml_exception_pointer */ - movq young_ptr(%rip), %r15 + /* Restore caml_young_ptr, caml_exception_pointer */ + movq caml_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 + cmpq caml_young_limit(%rip), %r15 jb .L100 ret .L100: @@ -127,7 +127,7 @@ FUNCTION(caml_alloc1) FUNCTION(caml_alloc2) subq $24, %r15 - cmpq young_limit(%rip), %r15 + cmpq caml_young_limit(%rip), %r15 jb .L101 ret .L101: @@ -142,7 +142,7 @@ FUNCTION(caml_alloc2) FUNCTION(caml_alloc3) subq $32, %r15 - cmpq young_limit(%rip), %r15 + cmpq caml_young_limit(%rip), %r15 jb .L102 ret .L102: @@ -155,9 +155,9 @@ FUNCTION(caml_alloc3) addq $8, %rsp jmp caml_alloc3 -FUNCTION(caml_alloc) +FUNCTION(caml_allocN) subq %rax, %r15 - cmpq young_limit(%rip), %r15 + cmpq caml_young_limit(%rip), %r15 jb .L103 ret .L103: @@ -168,7 +168,7 @@ FUNCTION(caml_alloc) movq %rax, caml_bottom_of_stack(%rip) call .L105 popq %rax /* recover desired size */ - jmp caml_alloc + jmp caml_allocN /* Call a C function from Caml */ @@ -178,12 +178,12 @@ FUNCTION(caml_c_call) 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 %r15, caml_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 + movq caml_young_ptr(%rip), %r15 /* Return to caller */ pushq %r12 ret @@ -201,7 +201,7 @@ FUNCTION(caml_start_program) 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* */ + /* Common code for caml_start_program and caml_callback* */ .L106: /* Build a callback link */ subq $8, %rsp /* stack 16-aligned */ @@ -209,7 +209,7 @@ FUNCTION(caml_start_program) 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_young_ptr(%rip), %r15 movq caml_exception_pointer(%rip), %r14 /* Build an exception handler */ lea .L108(%rip), %r13 @@ -224,7 +224,7 @@ FUNCTION(caml_start_program) popq %r12 /* dummy register */ .L109: /* Update alloc ptr and exception ptr */ - movq %r15, young_ptr(%rip) + movq %r15, caml_young_ptr(%rip) movq %r14, caml_exception_pointer(%rip) /* Pop the callback link, restoring the global variables */ popq caml_bottom_of_stack(%rip) @@ -249,15 +249,16 @@ FUNCTION(caml_start_program) /* Raise an exception from C */ -FUNCTION(raise_caml_exception) +FUNCTION(caml_raise_exception) movq %rdi, %rax movq caml_exception_pointer(%rip), %rsp - popq caml_exception_pointer(%rip) + popq %r14 /* Recover previous exception handler */ + movq caml_young_ptr(%rip), %r15 /* Reload alloc ptr */ ret /* Callback from C to Caml */ -FUNCTION(callback_exn) +FUNCTION(caml_callback_exn) /* Save callee-save registers */ pushq %rbx pushq %rbp @@ -272,7 +273,7 @@ FUNCTION(callback_exn) movq 0(%rbx), %r12 /* code pointer */ jmp .L106 -FUNCTION(callback2_exn) +FUNCTION(caml_callback2_exn) /* Save callee-save registers */ pushq %rbx pushq %rbp @@ -288,7 +289,7 @@ FUNCTION(callback2_exn) leaq caml_apply2(%rip), %r12 /* code pointer */ jmp .L106 -FUNCTION(callback3_exn) +FUNCTION(caml_callback3_exn) /* Save callee-save registers */ pushq %rbx pushq %rbp @@ -305,24 +306,24 @@ FUNCTION(callback3_exn) leaq caml_apply3(%rip), %r12 /* code pointer */ jmp .L106 -FUNCTION(caml_array_bound_error) +FUNCTION(caml_ml_array_bound_error) /* Make the exception handler and alloc ptr available to the C code */ - movq %r15, young_ptr(%rip) + movq %r15, caml_young_ptr(%rip) movq %r14, caml_exception_pointer(%rip) - jmp array_bound_error + jmp caml_array_bound_error .data - .globl system__frametable - .type system__frametable,@object + .globl caml_system__frametable + .type caml_system__frametable,@object .align 8 -system__frametable: +caml_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 + .section .rodata.cst8,"a",@progbits .globl caml_negf_mask .type caml_negf_mask,@object .align 16 diff --git a/asmrun/arm.S b/asmrun/arm.S index 703eab37..109e930c 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: arm.S,v 1.11 2002/02/08 16:55:32 xleroy Exp $ */ +/* $Id: arm.S,v 1.15 2004/01/03 12:51:18 doligez Exp $ */ /* Asm part of the runtime system, ARM processor */ @@ -80,8 +80,8 @@ caml_alloc3: /* Try again */ b caml_alloc3 - .global caml_alloc -caml_alloc: + .global caml_allocN +caml_allocN: str r12, [sp, #-4]! ldr r12, [alloc_limit, #0] sub alloc_ptr, alloc_ptr, r10 @@ -96,7 +96,7 @@ caml_alloc: bl .Linvoke_gc /* Try again */ ldr r10, .Lcaml_requested_size - b caml_alloc + b caml_allocN /* Shared code to invoke the GC */ .Linvoke_gc: @@ -114,13 +114,13 @@ caml_alloc: stfd f2, [sp, #-8]! stfd f3, [sp, #-8]! /* Save current allocation pointer for debugging purposes */ - ldr r10, .Lyoung_ptr + ldr r10, .Lcaml_young_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 + bl caml_garbage_collection /* Restore the registers from the stack */ ldfd f4, [sp], #8 ldfd f5, [sp], #8 @@ -134,9 +134,9 @@ caml_alloc: mov alloc_ptr, #0 str alloc_ptr, [r10, #0] /* Reload new allocation pointer and allocation limit */ - ldr r10, .Lyoung_ptr + ldr r10, .Lcaml_young_ptr ldr alloc_ptr, [r10, #0] - ldr alloc_limit, .Lyoung_limit + ldr alloc_limit, .Lcaml_young_limit /* Return to caller */ ldmfd sp!, {pc} @@ -153,7 +153,7 @@ caml_c_call: 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 r6, .Lcaml_young_ptr ldr r7, .Lcaml_exception_pointer str alloc_ptr, [r6, #0] str trap_ptr, [r7, #0] @@ -161,7 +161,7 @@ caml_c_call: mov lr, pc mov pc, r10 /* Reload alloc ptr */ - ldr alloc_ptr, [r6, #0] /* r6 still points to young_ptr */ + ldr alloc_ptr, [r6, #0] /* r6 still points to caml_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 */ @@ -174,7 +174,7 @@ caml_c_call: caml_start_program: ldr r10, .Lcaml_program -/* Code shared with callback* */ +/* Code shared with caml_callback* */ /* Address of Caml code to call is in r10 */ /* Arguments to the Caml code are in r0...r3 */ @@ -205,9 +205,9 @@ caml_start_program: str r4, [sp, #4] mov trap_ptr, sp /* Reload allocation pointers */ - ldr r4, .Lyoung_ptr + ldr r4, .Lcaml_young_ptr ldr alloc_ptr, [r4, #0] - ldr alloc_limit, .Lyoung_limit + ldr alloc_limit, .Lcaml_young_limit /* We are back into Caml code */ ldr r4, .Lcaml_last_return_address mov r5, #0 @@ -234,7 +234,7 @@ caml_start_program: str r5, [r4, #0] add sp, sp, #4*3 /* Update allocation pointer */ - ldr r4, .Lyoung_ptr + ldr r4, .Lcaml_young_ptr str alloc_ptr, [r4, #0] /* Reload callee-save registers and return */ ldfd f4, [sp], #8 @@ -255,12 +255,12 @@ caml_start_program: /* Raise an exception from C */ - .global raise_caml_exception -raise_caml_exception: + .global caml_raise_exception +caml_raise_exception: /* Reload Caml allocation pointers */ - ldr r1, .Lyoung_ptr + ldr r1, .Lcaml_young_ptr ldr alloc_ptr, [r1, #0] - ldr alloc_limit, .Lyoung_limit + ldr alloc_limit, .Lcaml_young_limit /* Say we're back into Caml */ ldr r1, .Lcaml_last_return_address mov r2, #0 @@ -273,8 +273,8 @@ raise_caml_exception: /* Callback from C to Caml */ - .global callback_exn -callback_exn: + .global caml_callback_exn +caml_callback_exn: /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */ mov r10, r0 mov r0, r1 /* r0 = first arg */ @@ -282,8 +282,8 @@ callback_exn: ldr r10, [r10, #0] /* code pointer */ b .Ljump_to_caml - .global callback2_exn -callback2_exn: + .global caml_callback2_exn +caml_callback2_exn: /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */ mov r10, r0 mov r0, r1 /* r0 = first arg */ @@ -292,8 +292,8 @@ callback2_exn: ldr r10, .Lcaml_apply2 b .Ljump_to_caml - .global callback3_exn -callback3_exn: + .global caml_callback3_exn +caml_callback3_exn: /* Initial shuffling of arguments */ /* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */ mov r10, r0 @@ -304,10 +304,10 @@ callback3_exn: 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 + .global caml_ml_array_bound_error +caml_ml_array_bound_error: + /* Load address of [caml_array_bound_error] in r10 */ + ldr r10, .Lcaml_array_bound_error /* Call that function */ b caml_c_call @@ -316,22 +316,22 @@ caml_array_bound_error: .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_young_ptr: .word caml_young_ptr +.Lcaml_young_limit: .word caml_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 +.Lcaml_array_bound_error: .word caml_array_bound_error /* GC roots for callback */ .data - .global system__frametable -system__frametable: + .global caml_system__frametable +caml_system__frametable: .word 1 /* one descriptor */ .word .Lcaml_retaddr /* return address into callback */ .short -1 /* negative frame size => use callback link */ diff --git a/asmrun/fail.c b/asmrun/fail.c index 30417640..4852327d 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fail.c,v 1.30 2001/12/07 13:39:19 xleroy Exp $ */ +/* $Id: fail.c,v 1.37 2004/05/17 17:25:52 doligez Exp $ */ /* Raising exceptions from C. */ @@ -31,127 +31,132 @@ typedef value caml_generated_constant[1]; -extern caml_generated_constant Out_of_memory, Sys_error, Failure, - Invalid_argument, End_of_file, Division_by_zero, Not_found, - Match_failure, Sys_blocked_io, Stack_overflow; +extern caml_generated_constant + caml_exn_Out_of_memory, + caml_exn_Sys_error, + caml_exn_Failure, + caml_exn_Invalid_argument, + caml_exn_End_of_file, + caml_exn_Division_by_zero, + caml_exn_Not_found, + caml_exn_Match_failure, + caml_exn_Sys_blocked_io, + caml_exn_Stack_overflow; +extern caml_generated_constant + caml_bucket_Out_of_memory, + caml_bucket_Stack_overflow; /* Exception raising */ -extern void raise_caml_exception (value bucket) Noreturn; +extern void caml_raise_exception (value bucket) Noreturn; char * caml_exception_pointer = NULL; -void mlraise(value v) +void caml_raise(value v) { Unlock_exn(); - if (caml_exception_pointer == NULL) fatal_uncaught_exception(v); + if (caml_exception_pointer == NULL) caml_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; + while (caml_local_roots != NULL && + (char *) caml_local_roots PUSHED_AFTER caml_exception_pointer) { + caml_local_roots = caml_local_roots->next; } #undef PUSHED_AFTER - raise_caml_exception(v); + caml_raise_exception(v); } -void raise_constant(value tag) +void caml_raise_constant(value tag) { - value bucket; - Begin_root (tag); - bucket = alloc_small (1, 0); - Field(bucket, 0) = tag; - End_roots (); - mlraise(bucket); + CAMLparam1 (tag); + CAMLlocal1 (bucket); + + bucket = caml_alloc_small (1, 0); + Field(bucket, 0) = tag; + caml_raise(bucket); + CAMLnoreturn; } -void raise_with_arg(value tag, value arg) +void caml_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); + CAMLparam2 (tag, arg); + CAMLlocal1 (bucket); + + bucket = caml_alloc_small (2, 0); + Field(bucket, 0) = tag; + Field(bucket, 1) = arg; + caml_raise(bucket); + CAMLnoreturn; } -void raise_with_string(value tag, char *msg) +void caml_raise_with_string(value tag, char *msg) { - raise_with_arg(tag, copy_string(msg)); + caml_raise_with_arg(tag, caml_copy_string(msg)); } -void failwith (char *msg) +void caml_failwith (char *msg) { - raise_with_string((value) Failure, msg); + caml_raise_with_string((value) caml_exn_Failure, msg); } -void invalid_argument (char *msg) +void caml_invalid_argument (char *msg) { - raise_with_string((value) Invalid_argument, msg); + caml_raise_with_string((value) caml_exn_Invalid_argument, msg); } -/* To raise Out_of_memory, we can't use raise_constant, +/* To raise [Out_of_memory], we can't use [caml_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 + We therefore use a statically-allocated bucket constructed + by the ocamlopt linker. + This works OK because the exception value for [Out_of_memory] is also statically allocated out of the heap. The same applies to Stack_overflow. */ -static struct { - header_t hdr; - value exn; -} out_of_memory_bucket, stack_overflow_bucket; - -void raise_out_of_memory(void) +void caml_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)); + caml_raise((value) &caml_bucket_Out_of_memory); } -void raise_stack_overflow(void) +void caml_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)); + caml_raise((value) &caml_bucket_Stack_overflow); } -void raise_sys_error(value msg) +void caml_raise_sys_error(value msg) { - raise_with_arg((value) Sys_error, msg); + caml_raise_with_arg((value) caml_exn_Sys_error, msg); } -void raise_end_of_file(void) +void caml_raise_end_of_file(void) { - raise_constant((value) End_of_file); + caml_raise_constant((value) caml_exn_End_of_file); } -void raise_zero_divide(void) +void caml_raise_zero_divide(void) { - raise_constant((value) Division_by_zero); + caml_raise_constant((value) caml_exn_Division_by_zero); } -void raise_not_found(void) +void caml_raise_not_found(void) { - raise_constant((value) Not_found); + caml_raise_constant((value) caml_exn_Not_found); } -void raise_sys_blocked_io(void) +void caml_raise_sys_blocked_io(void) { - raise_constant((value) Sys_blocked_io); + caml_raise_constant((value) caml_exn_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 */ + for the ccall to [caml_array_bound_error]. */ -#define BOUND_MSG "out-of-bound array or string access" +#define BOUND_MSG "index out of bounds" #define BOUND_MSG_LEN (sizeof(BOUND_MSG) - 1) static struct { @@ -165,14 +170,14 @@ static struct { char data[BOUND_MSG_LEN + sizeof(value)]; } array_bound_error_msg = { 0, BOUND_MSG }; -void array_bound_error(void) +void caml_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.exn = (value) caml_exn_Invalid_argument; array_bound_error_bucket.arg = (value) array_bound_error_msg.data; - mlraise((value) &array_bound_error_bucket.exn); + caml_raise((value) &array_bound_error_bucket.exn); } diff --git a/asmrun/hppa.S b/asmrun/hppa.S index c7e29147..9bffb23a 100644 --- a/asmrun/hppa.S +++ b/asmrun/hppa.S @@ -11,7 +11,7 @@ ;* * ;********************************************************************* -; $Id: hppa.S,v 1.20 2002/02/08 16:55:32 xleroy Exp $ +; $Id: hppa.S,v 1.25 2004/05/16 09:09:22 xleroy Exp $ ; Asm part of the runtime system for the HP PA-RISC processor. ; Must be preprocessed by cpp @@ -30,18 +30,18 @@ #define LOWLABEL(x) RR%x #endif -#ifdef SYS_nextstep -#define G(x) _##x +#ifdef SYS_linux +#define G(x) x #define CODESPACE .text -#define CODE_ALIGN 2 +#define CODE_ALIGN 8 #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 +#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_hpux @@ -53,15 +53,15 @@ .subspa $CODE$,quad=0,align=8,access=44,code_only .import $global$, data .import $$dyncall, millicode - .import garbage_collection, code + .import caml_garbage_collection, code .import caml_program, code - .import mlraise, code + .import caml_raise, code .import caml_apply2, code .import caml_apply3, code - .import array_bound_error, code + .import caml_array_bound_error, code -young_limit .comm 8 -young_ptr .comm 8 +caml_young_limit .comm 8 +caml_young_ptr .comm 8 caml_bottom_of_stack .comm 8 caml_last_return_address .comm 8 caml_gc_regs .comm 8 @@ -69,22 +69,23 @@ 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 +#ifdef SYS_linux + .align 8 + .comm G(young_limit), 4 + .comm G(young_ptr), 4 + .comm G(caml_bottom_of_stack), 4 + .comm G(caml_last_return_address), 4 + .comm G(caml_gc_regs), 4 + .comm G(caml_exception_pointer), 4 + .comm G(caml_required_size), 4 #endif ; Allocation functions CODESPACE .align CODE_ALIGN - EXPORT_CODE(G(caml_alloc)) -G(caml_alloc): + EXPORT_CODE(G(caml_allocN)) +G(caml_allocN): STARTPROC ; Required size in %r29 ldw 0(%r4), %r1 @@ -101,8 +102,8 @@ G(caml_call_gc): 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) + LOADHIGH(G(caml_young_ptr)) + stw %r3, LOW(G(caml_young_ptr))(%r1) ; Record lowest stack address LOADHIGH(G(caml_bottom_of_stack)) stw %r30, LOW(G(caml_bottom_of_stack))(%r1) @@ -173,14 +174,8 @@ L100: ldo -(64 + 4*32)(%r30), %r31 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 + bl G(caml_garbage_collection), %r2 nop -#endif ; Restore all regs used by the code generator ldo -(64 + 4*32)(%r30), %r1 @@ -236,8 +231,8 @@ L100: ldo -(64 + 4*32)(%r30), %r31 fldds,ma 8(%r1), %fr30 ; Reload the allocation pointer - LOADHIGH(G(young_ptr)) - ldw LOW(G(young_ptr))(%r1), %r3 + LOADHIGH(G(caml_young_ptr)) + ldw LOW(G(caml_young_ptr))(%r1), %r3 ; Allocate space for block LOADHIGH(G(caml_required_size)) ldw LOW(G(caml_required_size))(%r1), %r29 @@ -273,8 +268,8 @@ G(caml_c_call): 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) + LOADHIGH(G(caml_young_ptr)) + stw %r3, LOW(G(caml_young_ptr))(%r1) ; Call the C function #ifdef SYS_hpux bl $$dyncall, %r31 @@ -286,10 +281,10 @@ G(caml_c_call): LOADHIGH(G(caml_last_return_address)) ldw LOW(G(caml_last_return_address))(%r1), %r2 ; Reload allocation pointer - LOADHIGH(G(young_ptr)) + LOADHIGH(G(caml_young_ptr)) ; Return to caller bv 0(%r2) - ldw LOW(G(young_ptr))(%r1), %r3 ; in delay slot + ldw LOW(G(caml_young_ptr))(%r1), %r3 ; in delay slot ENDPROC ; Start the Caml program @@ -301,7 +296,7 @@ G(caml_start_program): LOADHIGH(G(caml_program)) ldo LOW(G(caml_program))(%r1), %r22 -; Code shared with callback* +; Code shared with caml_callback* L102: ; Save return address stw %r2,-20(%r30) @@ -365,10 +360,10 @@ L102: 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 + LOADHIGH(G(caml_young_ptr)) + ldw LOW(G(caml_young_ptr))(%r1), %r3 + LOADHIGH(G(caml_young_limit)) + ldo LOW(G(caml_young_limit))(%r1), %r4 ; Call the Caml code ble 0(4, %r22) copy %r31, %r2 @@ -391,8 +386,8 @@ L105: 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) + LOADHIGH(G(caml_young_ptr)) + stw %r3, LOW(G(caml_young_ptr))(%r1) ; Move result where C function expects it copy %r26, %r28 ; Reload callee-save registers @@ -450,32 +445,26 @@ L103: b L105 nop -; Re-raise the exception through mlraise, to clean up local C roots +; Re-raise the exception through caml_raise, 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 + bl G(caml_raise), %r2 nop -#endif ENDPROC ; Raise an exception from C .align CODE_ALIGN - EXPORT_CODE(G(raise_caml_exception)) -G(raise_caml_exception): + EXPORT_CODE(G(caml_raise_exception)) +G(caml_raise_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 + LOADHIGH(G(caml_young_ptr)) + ldw LOW(G(caml_young_ptr))(%r1), %r3 + LOADHIGH(G(caml_young_limit)) + ldo LOW(G(caml_young_limit))(%r1), %r4 ; Raise the exception ldw -4(%r30), %r1 ldw -8(%r30), %r5 @@ -486,8 +475,8 @@ G(raise_caml_exception): ; Callbacks C -> ML .align CODE_ALIGN - EXPORT_CODE(G(callback_exn)) -G(callback_exn): + EXPORT_CODE(G(caml_callback_exn)) +G(caml_callback_exn): STARTPROC ; Initial shuffling of arguments copy %r26, %r1 ; Closure @@ -498,8 +487,8 @@ G(callback_exn): ENDPROC .align CODE_ALIGN - EXPORT_CODE(G(callback2_exn)) -G(callback2_exn): + EXPORT_CODE(G(caml_callback2_exn)) +G(caml_callback2_exn): STARTPROC copy %r26, %r1 ; Closure copy %r25, %r26 ; First argument @@ -511,8 +500,8 @@ G(callback2_exn): ENDPROC .align CODE_ALIGN - EXPORT_CODE(G(callback3_exn)) -G(callback3_exn): + EXPORT_CODE(G(caml_callback3_exn)) +G(caml_callback3_exn): STARTPROC copy %r26, %r1 ; Closure copy %r25, %r26 ; First argument @@ -525,25 +514,20 @@ G(callback3_exn): ENDPROC .align CODE_ALIGN - EXPORT_CODE(G(caml_array_bound_error)) -G(caml_array_bound_error): + EXPORT_CODE(G(caml_ml_array_bound_error)) +G(caml_ml_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 +; Load address of [caml_array_bound_error] in %r22 + ldil LR%caml_array_bound_error, %r22 + ldo RR%caml_array_bound_error(%r22), %r22 ; 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): + EXPORT_DATA(G(caml_system__frametable)) +G(caml_system__frametable): .long 1 /* one descriptor */ .long L104 + 3 /* return address into callback */ .short -1 /* negative frame size => use callback link */ diff --git a/asmrun/i386.S b/asmrun/i386.S index 9fe8ee53..a6f3a9f5 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: i386.S,v 1.38 2002/06/07 09:49:36 xleroy Exp $ */ +/* $Id: i386.S,v 1.42 2004/01/03 12:51:19 doligez Exp $ */ /* Asm part of the runtime system, Intel 386 processor */ /* Must be preprocessed by cpp */ @@ -70,7 +70,7 @@ .globl G(caml_alloc1) .globl G(caml_alloc2) .globl G(caml_alloc3) - .globl G(caml_alloc) + .globl G(caml_allocN) G(caml_call_gc): PROFILE_CAML @@ -90,7 +90,7 @@ LBL(105): pushl %eax movl %esp, G(caml_gc_regs) /* Call the garbage collector */ - call G(garbage_collection) + call G(caml_garbage_collection) /* Restore all regs used by the code generator */ popl %eax popl %ebx @@ -105,10 +105,10 @@ LBL(105): .align FUNCTION_ALIGN G(caml_alloc1): PROFILE_CAML - movl G(young_ptr), %eax + movl G(caml_young_ptr), %eax subl $8, %eax - movl %eax, G(young_ptr) - cmpl G(young_limit), %eax + movl %eax, G(caml_young_ptr) + cmpl G(caml_young_limit), %eax jb LBL(100) ret LBL(100): @@ -122,10 +122,10 @@ LBL(100): .align FUNCTION_ALIGN G(caml_alloc2): PROFILE_CAML - movl G(young_ptr), %eax + movl G(caml_young_ptr), %eax subl $12, %eax - movl %eax, G(young_ptr) - cmpl G(young_limit), %eax + movl %eax, G(caml_young_ptr) + cmpl G(caml_young_limit), %eax jb LBL(101) ret LBL(101): @@ -139,10 +139,10 @@ LBL(101): .align FUNCTION_ALIGN G(caml_alloc3): PROFILE_CAML - movl G(young_ptr), %eax + movl G(caml_young_ptr), %eax subl $16, %eax - movl %eax, G(young_ptr) - cmpl G(young_limit), %eax + movl %eax, G(caml_young_ptr) + cmpl G(caml_young_limit), %eax jb LBL(102) ret LBL(102): @@ -154,26 +154,26 @@ LBL(102): jmp G(caml_alloc3) .align FUNCTION_ALIGN -G(caml_alloc): +G(caml_allocN): PROFILE_CAML - subl G(young_ptr), %eax /* eax = size - young_ptr */ - negl %eax /* eax = young_ptr - size */ - cmpl G(young_limit), %eax + subl G(caml_young_ptr), %eax /* eax = size - caml_young_ptr */ + negl %eax /* eax = caml_young_ptr - size */ + cmpl G(caml_young_limit), %eax jb LBL(103) - movl %eax, G(young_ptr) + movl %eax, G(caml_young_ptr) ret LBL(103): - subl G(young_ptr), %eax /* eax = - size */ + subl G(caml_young_ptr), %eax /* eax = - size */ negl %eax /* eax = size */ pushl %eax /* save desired size */ - subl %eax, G(young_ptr) /* must update young_ptr */ + subl %eax, G(caml_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) + jmp G(caml_allocN) /* Call a C function from Caml */ @@ -202,7 +202,7 @@ G(caml_start_program): pushl %ebp /* Initial entry point is caml_program */ movl $ G(caml_program), %esi - /* Common code for caml_start_program and callback* */ + /* Common code for caml_start_program and caml_callback* */ LBL(106): /* Build a callback link */ pushl G(caml_gc_regs) @@ -238,9 +238,9 @@ LBL(108): /* Raise an exception from C */ - .globl G(raise_caml_exception) + .globl G(caml_raise_exception) .align FUNCTION_ALIGN -G(raise_caml_exception): +G(caml_raise_exception): PROFILE_C movl 4(%esp), %eax movl G(caml_exception_pointer), %esp @@ -249,9 +249,9 @@ G(raise_caml_exception): /* Callback from C to Caml */ - .globl G(callback_exn) + .globl G(caml_callback_exn) .align FUNCTION_ALIGN -G(callback_exn): +G(caml_callback_exn): PROFILE_C /* Save callee-save registers */ pushl %ebx @@ -264,9 +264,9 @@ G(callback_exn): movl 0(%ebx), %esi /* code pointer */ jmp LBL(106) - .globl G(callback2_exn) + .globl G(caml_callback2_exn) .align FUNCTION_ALIGN -G(callback2_exn): +G(caml_callback2_exn): PROFILE_C /* Save callee-save registers */ pushl %ebx @@ -280,9 +280,9 @@ G(callback2_exn): movl $ G(caml_apply2), %esi /* code pointer */ jmp LBL(106) - .globl G(callback3_exn) + .globl G(caml_callback3_exn) .align FUNCTION_ALIGN -G(callback3_exn): +G(caml_callback3_exn): PROFILE_C /* Save callee-save registers */ pushl %ebx @@ -297,9 +297,9 @@ G(callback3_exn): movl $ G(caml_apply3), %esi /* code pointer */ jmp LBL(106) - .globl G(caml_array_bound_error) + .globl G(caml_ml_array_bound_error) .align FUNCTION_ALIGN -G(caml_array_bound_error): +G(caml_ml_array_bound_error): /* Empty the floating-point stack */ ffree %st(0) ffree %st(1) @@ -309,12 +309,12 @@ G(caml_array_bound_error): ffree %st(5) ffree %st(6) ffree %st(7) - /* Branch to array_bound_error */ - jmp G(array_bound_error) + /* Branch to [caml_array_bound_error] */ + jmp G(caml_array_bound_error) .data - .globl G(system__frametable) -G(system__frametable): + .globl G(caml_system__frametable) +G(caml_system__frametable): .long 1 /* one descriptor */ .long LBL(107) /* return address into callback */ #ifndef SYS_solaris diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm index 8f993887..34da4354 100644 --- a/asmrun/i386nt.asm +++ b/asmrun/i386nt.asm @@ -11,21 +11,20 @@ ; ;********************************************************************* -; $Id: i386nt.asm,v 1.16 2003/06/30 15:39:39 xleroy Exp $ +; $Id: i386nt.asm,v 1.17 2004/05/04 09:02:47 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_garbage_collection: 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_array_bound_error: PROC + EXTERN _caml_young_limit: DWORD + EXTERN _caml_young_ptr: DWORD EXTERN _caml_bottom_of_stack: DWORD EXTERN _caml_last_return_address: DWORD EXTERN _caml_gc_regs: DWORD @@ -37,7 +36,7 @@ PUBLIC _caml_alloc1 PUBLIC _caml_alloc2 PUBLIC _caml_alloc3 - PUBLIC _caml_alloc + PUBLIC _caml_allocN PUBLIC _caml_call_gc _caml_call_gc: @@ -56,7 +55,7 @@ L105: push ebp push eax mov _caml_gc_regs, esp ; Call the garbage collector - call _garbage_collection + call _caml_garbage_collection ; Restore all regs used by the code generator pop eax pop ebx @@ -70,10 +69,10 @@ L105: push ebp ALIGN 4 _caml_alloc1: - mov eax, _young_ptr + mov eax, _caml_young_ptr sub eax, 8 - mov _young_ptr, eax - cmp eax, _young_limit + mov _caml_young_ptr, eax + cmp eax, _caml_young_limit jb L100 ret L100: mov eax, [esp] @@ -85,10 +84,10 @@ L100: mov eax, [esp] ALIGN 4 _caml_alloc2: - mov eax, _young_ptr + mov eax, _caml_young_ptr sub eax, 12 - mov _young_ptr, eax - cmp eax, _young_limit + mov _caml_young_ptr, eax + cmp eax, _caml_young_limit jb L101 ret L101: mov eax, [esp] @@ -100,10 +99,10 @@ L101: mov eax, [esp] ALIGN 4 _caml_alloc3: - mov eax, _young_ptr + mov eax, _caml_young_ptr sub eax, 16 - mov _young_ptr, eax - cmp eax, _young_limit + mov _caml_young_ptr, eax + cmp eax, _caml_young_limit jb L102 ret L102: mov eax, [esp] @@ -114,24 +113,24 @@ L102: mov eax, [esp] jmp _caml_alloc3 ALIGN 4 -_caml_alloc: - sub eax, _young_ptr ; eax = size - young_ptr +_caml_allocN: + sub eax, _caml_young_ptr ; eax = size - young_ptr neg eax ; eax = young_ptr - size - cmp eax, _young_limit + cmp eax, _caml_young_limit jb L103 - mov _young_ptr, eax + mov _caml_young_ptr, eax ret -L103: sub eax, _young_ptr ; eax = - size +L103: sub eax, _caml_young_ptr ; eax = - size neg eax ; eax = size push eax ; save desired size - sub _young_ptr, eax ; must update young_ptr + sub _caml_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 + jmp _caml_allocN ; Call a C function from Caml @@ -197,9 +196,9 @@ L108: ; Raise an exception from C - PUBLIC _raise_caml_exception + PUBLIC _caml_raise_exception ALIGN 4 -_raise_caml_exception: +_caml_raise_exception: mov eax, [esp+4] mov esp, _caml_exception_pointer pop _caml_exception_pointer @@ -207,9 +206,9 @@ _raise_caml_exception: ; Callback from C to Caml - PUBLIC _callback_exn + PUBLIC _caml_callback_exn ALIGN 4 -_callback_exn: +_caml_callback_exn: ; Save callee-save registers push ebx push esi @@ -221,9 +220,9 @@ _callback_exn: mov esi, [ebx] ; code pointer jmp L106 - PUBLIC _callback2_exn + PUBLIC _caml_callback2_exn ALIGN 4 -_callback2_exn: +_caml_callback2_exn: ; Save callee-save registers push ebx push esi @@ -236,9 +235,9 @@ _callback2_exn: mov esi, offset _caml_apply2 ; code pointer jmp L106 - PUBLIC _callback3_exn + PUBLIC _caml_callback3_exn ALIGN 4 -_callback3_exn: +_caml_callback3_exn: ; Save callee-save registers push ebx push esi @@ -252,9 +251,9 @@ _callback3_exn: mov esi, offset _caml_apply3 ; code pointer jmp L106 - PUBLIC _caml_array_bound_error + PUBLIC _caml_ml_array_bound_error ALIGN 4 -_caml_array_bound_error: +_caml_ml_array_bound_error: ; Empty the floating-point stack ffree st(0) ffree st(1) @@ -265,11 +264,11 @@ _caml_array_bound_error: ffree st(6) ffree st(7) ; Branch to array_bound_error - jmp _array_bound_error + jmp _caml_array_bound_error .DATA - PUBLIC _system__frametable -_system__frametable LABEL DWORD + PUBLIC _caml_system__frametable +_caml_system__frametable LABEL DWORD DWORD 1 ; one descriptor DWORD L107 ; return address into callback WORD -1 ; negative frame size => use callback link diff --git a/asmrun/ia64.S b/asmrun/ia64.S index b474a029..ad74a9f6 100644 --- a/asmrun/ia64.S +++ b/asmrun/ia64.S @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: ia64.S,v 1.9 2002/06/03 14:22:30 xleroy Exp $ */ +/* $Id: ia64.S,v 1.13 2004/01/03 12:51:19 doligez Exp $ */ /* Asm part of the runtime system, Alpha processor */ @@ -57,14 +57,14 @@ /* Allocation */ .text - .global caml_alloc# - .proc caml_alloc# + .global caml_allocN# + .proc caml_allocN# .align 16 -/* caml_alloc: all code generator registers preserved, +/* caml_allocN: all code generator registers preserved, gp preserved, r2 = requested size */ -caml_alloc: +caml_allocN: sub r4 = r4, r2 ;; cmp.ltu p0, p6 = r4, r5 (p6) br.ret.sptk b0 ;; @@ -78,7 +78,7 @@ caml_alloc: mov b0 = r3 ;; br.ret.sptk b0 - .endp caml_alloc# + .endp caml_allocN# /* caml_call_gc: all code generator registers preserved, gp preserved, r2 = requested size */ @@ -126,13 +126,13 @@ caml_call_gc: FSAVE8(f56,f57,f58,f59,f60,f61,f62,f63) ;; /* Save current allocation pointer for debugging purposes */ - STOREGLOBAL(r4, young_ptr#) + STOREGLOBAL(r4, caml_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# ;; + br.call.sptk b0 = caml_garbage_collection# ;; /* Restore gp */ add r3 = 24, sp ;; @@ -162,8 +162,8 @@ caml_call_gc: FLOAD8(f56,f57,f58,f59,f60,f61,f62,f63) ;; /* Reload new allocation pointer and allocation limit */ - LOADGLOBAL(r4, young_ptr#) - LOADGLOBAL(r5, young_limit#) + LOADGLOBAL(r4, caml_young_ptr#) + LOADGLOBAL(r5, caml_young_limit#) /* Allocate space for the block */ add r3 = 16, sp ;; @@ -208,7 +208,7 @@ caml_c_call: STOREGLOBAL(r14, caml_last_return_address#) /* Make the exception handler and alloc ptr available to the C code */ - STOREGLOBAL(r4, young_ptr#) + STOREGLOBAL(r4, caml_young_ptr#) STOREGLOBAL(r6, caml_exception_pointer#) /* Recover gp from the function pointer in r2 */ @@ -221,8 +221,8 @@ caml_c_call: mov gp = r7 ;; /* Reload alloc ptr and alloc limit */ - LOADGLOBAL(r4, young_ptr#) - LOADGLOBAL(r5, young_limit#) + LOADGLOBAL(r4, caml_young_ptr#) + LOADGLOBAL(r5, caml_young_limit#) /* Reload return address and say that we are back into Caml code */ ADDRGLOBAL(r3, caml_last_return_address#) ;; @@ -245,7 +245,7 @@ caml_start_program: ADDRGLOBAL(r2, caml_program#) ;; mov b6 = r2 - /* Code shared with callback* */ + /* Code shared with caml_callback* */ .L103: /* Allocate 64 "out" registers (for the Caml code) and no locals */ alloc r3 = ar.pfs, 0, 0, 64, 0 @@ -324,8 +324,8 @@ caml_start_program: mov ar.rsc = r14 /* restore original RSE mode */ /* Reload allocation pointers */ - LOADGLOBAL(r4, young_ptr#) - LOADGLOBAL(r5, young_limit#) + LOADGLOBAL(r4, caml_young_ptr#) + LOADGLOBAL(r5, caml_young_limit#) /* We are back into Caml code */ STOREGLOBAL(r0, caml_last_return_address#) @@ -355,7 +355,7 @@ caml_start_program: add sp = 48, sp /* Update allocation pointer */ - STOREGLOBAL(r4, young_ptr#) + STOREGLOBAL(r4, caml_young_ptr#) /* Restore all callee-save registers from stack */ add r2 = 16, sp ;; @@ -410,10 +410,10 @@ caml_start_program: /* Raise an exception from C */ - .global raise_caml_exception# - .proc raise_caml_exception# + .global caml_raise_exception# + .proc caml_raise_exception# .align 16 -raise_caml_exception: +caml_raise_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 @@ -436,8 +436,8 @@ raise_caml_exception: mov ar.rsc = r14 ;; /* Restore original RSE mode */ /* Reload allocation pointers and exception pointer */ - LOADGLOBAL(r4, young_ptr#) - LOADGLOBAL(r5, young_limit#) + LOADGLOBAL(r4, caml_young_ptr#) + LOADGLOBAL(r5, caml_young_limit#) LOADGLOBAL(r6, caml_exception_pointer#) /* Say that we're back into Caml */ @@ -454,14 +454,14 @@ raise_caml_exception: CFM and PFS correctly. */ br.call.sptk.many b0 = b6 - .endp raise_caml_exception + .endp caml_raise_exception /* Callbacks from C to Caml */ - .global callback_exn# - .proc callback_exn# + .global caml_callback_exn# + .proc caml_callback_exn# .align 16 -callback_exn: +caml_callback_exn: /* Initial shuffling of arguments */ ld8 r3 = [r32] /* code pointer */ mov r2 = r32 @@ -470,12 +470,12 @@ callback_exn: mov b6 = r3 br.sptk .L103 ;; - .endp callback_exn# + .endp caml_callback_exn# - .global callback2_exn# - .proc callback2_exn# + .global caml_callback2_exn# + .proc caml_callback2_exn# .align 16 -callback2_exn: +caml_callback2_exn: /* Initial shuffling of arguments */ ADDRGLOBAL(r3, caml_apply2) /* code pointer */ mov r2 = r32 @@ -485,12 +485,12 @@ callback2_exn: mov b6 = r3 br.sptk .L103 ;; - .endp callback2_exn# + .endp caml_callback2_exn# - .global callback3_exn# - .proc callback3_exn# + .global caml_callback3_exn# + .proc caml_callback3_exn# .align 16 -callback3_exn: +caml_callback3_exn: /* Initial shuffling of arguments */ ADDRGLOBAL(r3, caml_apply3) /* code pointer */ mov r2 = r32 @@ -501,30 +501,30 @@ callback3_exn: mov b6 = r3 br.sptk .L103 ;; - .endp callback3_exn# + .endp caml_callback3_exn# -/* Glue code to call array_bound_error */ +/* Glue code to call [caml_array_bound_error] */ - .global caml_array_bound_error# - .proc caml_array_bound_error# + .global caml_ml_array_bound_error# + .proc caml_ml_array_bound_error# .align 16 -caml_array_bound_error: - ADDRGLOBAL(r2, @fptr(array_bound_error#)) +caml_ml_array_bound_error: + ADDRGLOBAL(r2, @fptr(caml_array_bound_error#)) br.sptk caml_c_call /* never returns */ .rodata - .global system__frametable# - .type system__frametable#, @object - .size system__frametable#, 8 -system__frametable: + .global caml_system__frametable# + .type caml_system__frametable#, @object + .size caml_system__frametable#, 8 +caml_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 */ +/* Global variables used by caml_raise_exception */ .common caml_saved_bsp#, 8, 8 .common caml_saved_rnat#, 8, 8 diff --git a/asmrun/m68k.S b/asmrun/m68k.S index 78ff2447..8e6e9c3d 100644 --- a/asmrun/m68k.S +++ b/asmrun/m68k.S @@ -11,7 +11,7 @@ |* * |*********************************************************************** -| $Id: m68k.S,v 1.11 2002/02/08 16:55:32 xleroy Exp $ +| $Id: m68k.S,v 1.15 2004/01/03 12:51:19 doligez Exp $ | Asm part of the runtime system, Motorola 68k processor @@ -24,7 +24,7 @@ .globl _caml_alloc1 .globl _caml_alloc2 .globl _caml_alloc3 - .globl _caml_alloc + .globl _caml_allocN _caml_call_gc: | Save desired size @@ -35,7 +35,7 @@ _caml_call_gc: addql #4, d5 movel d5, _caml_bottom_of_stack | Record current allocation pointer (for debugging) - movel d6, _young_ptr + movel d6, _caml_young_ptr | Save all regs used by the code generator movel d4, a7@- movel d3, a7@- @@ -52,7 +52,7 @@ _caml_call_gc: movel a7, _caml_gc_regs fmovem fp0-fp7, a7@- | Call the garbage collector - jbsr _garbage_collection + jbsr _caml_garbage_collection | Restore all regs used by the code generator fmovem a7@+, fp0-fp7 movel a7@+, a0 @@ -68,14 +68,14 @@ _caml_call_gc: movel a7@+, d3 movel a7@+, d4 | Reload allocation pointer and allocate block - movel _young_ptr, d6 + movel _caml_young_ptr, d6 subl _caml_requested_size, d6 | Return to caller rts _caml_alloc1: subql #8, d6 - cmpl _young_limit, d6 + cmpl _caml_young_limit, d6 bcs L100 rts L100: moveq #8, d5 @@ -83,7 +83,7 @@ L100: moveq #8, d5 _caml_alloc2: subl #12, d6 - cmpl _young_limit, d6 + cmpl _caml_young_limit, d6 bcs L101 rts L101: moveq #12, d5 @@ -91,15 +91,15 @@ L101: moveq #12, d5 _caml_alloc3: subl #16, d6 - cmpl _young_limit, d6 + cmpl _caml_young_limit, d6 bcs L102 rts L102: moveq #16, d5 bra _caml_call_gc -_caml_alloc: +_caml_allocN: subl d5, d6 - cmpl _young_limit, d6 + cmpl _caml_young_limit, d6 bcs _caml_call_gc rts @@ -112,12 +112,12 @@ _caml_c_call: movel a7@+, _caml_last_return_address movel a7, _caml_bottom_of_stack | Save allocation pointer and exception pointer - movel d6, _young_ptr + movel d6, _caml_young_ptr movel d7, _caml_exception_pointer | Call the function (address in a0) jbsr a0@ | Reload allocation pointer - movel _young_ptr, d6 + movel _caml_young_ptr, d6 | Return to caller movel _caml_last_return_address, a1 jmp a1@ @@ -133,7 +133,7 @@ _caml_start_program: | Initial code point is caml_program lea _caml_program, a5 -| Code shared between caml_start_program and callback* +| Code shared between caml_start_program and caml_callback* L106: | Build a callback link @@ -145,14 +145,14 @@ L106: movel _caml_exception_pointer, a7@- movel a7, d7 | Load allocation pointer - movel _young_ptr, d6 + movel _caml_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 + movel d6, _caml_young_ptr | Pop the exception handler movel a7@+, _caml_exception_pointer addql #4, a7 @@ -170,7 +170,7 @@ L109: L108: | Exception handler | Save allocation pointer and exception pointer - movel d6, _young_ptr + movel d6, _caml_young_ptr movel d7, _caml_exception_pointer | Encode exception bucket as an exception result movel a0, d0 @@ -180,18 +180,18 @@ L108: | Raise an exception from C - .globl _raise_caml_exception -_raise_caml_exception: + .globl _caml_raise_exception +_caml_raise_exception: movel a7@(4), a0 | exception bucket - movel _young_ptr, d6 + movel _caml_young_ptr, d6 movel _caml_exception_pointer, a7 movel a7@+, d7 rts | Callback from C to Caml - .globl _callback_exn -_callback_exn: + .globl _caml_callback_exn +_caml_callback_exn: link a6, #0 | Save callee-save registers moveml a2-a6/d2-d7, a7@- @@ -202,8 +202,8 @@ _callback_exn: movel a1@(0), a5 | code pointer bra L106 - .globl _callback2_exn -_callback2_exn: + .globl _caml_callback2_exn +_caml_callback2_exn: link a6, #0 | Save callee-save registers moveml a2-a6/d2-d7, a7@- @@ -215,8 +215,8 @@ _callback2_exn: lea _caml_apply2, a5 | code pointer bra L106 - .globl _callback3_exn -_callback3_exn: + .globl _caml_callback3_exn +_caml_callback3_exn: link a6, #0 | Save callee-save registers moveml a2-a6/d2-d7, a7@- @@ -229,15 +229,15 @@ _callback3_exn: 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 + .globl _caml_ml_array_bound_error +_caml_ml_array_bound_error: + | Load address of [caml_array_bound_error] in a0 and call it + lea _caml_array_bound_error, a0 bra _caml_c_call .data - .globl _system__frametable -_system__frametable: + .globl _caml_system__frametable +_caml_system__frametable: .long 1 | one descriptor .long L107 | return address into callback .word -1 | negative frame size => use callback link diff --git a/asmrun/mips.s b/asmrun/mips.s index d1714318..50239bc4 100644 --- a/asmrun/mips.s +++ b/asmrun/mips.s @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: mips.s,v 1.7 2002/03/11 08:38:52 xleroy Exp $ */ +/* $Id: mips.s,v 1.11 2004/01/03 12:51:19 doligez Exp $ */ /* Asm part of the runtime system, Mips processor, IRIX n32 conventions */ @@ -39,7 +39,7 @@ caml_call_gc: addu $24, $sp, 0x100 sw $24, caml_gc_regs /* Save current allocation pointer for debugging purposes */ - sw $22, young_ptr + sw $22, caml_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 */ @@ -152,8 +152,8 @@ caml_call_gc: 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 + lw $22, caml_young_ptr + lw $23, caml_young_limit /* Reload return address */ lw $31, caml_last_return_address /* Say that we are back into Caml code */ @@ -179,19 +179,19 @@ caml_c_call: /* Preload addresses of interesting global variables in callee-save registers */ la $16, caml_last_return_address - la $17, young_ptr + la $17, caml_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 $22, 0($17) /* caml_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 */ + lw $22, 0($17) /* caml_young_ptr */ + lw $23, caml_young_limit /* caml_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 */ @@ -211,7 +211,7 @@ caml_start_program: .cpsetup $25, 0x80, caml_start_program /* Load in $24 the code address to call */ la $24, caml_program - /* Code shared with callback* */ + /* Code shared with caml_callback* */ $103: /* Save return address */ sd $31, 0x88($sp) @@ -248,8 +248,8 @@ $103: sw $gp, 8($sp) move $30, $sp /* Reload allocation pointers */ - lw $22, young_ptr - lw $23, young_limit + lw $22, caml_young_ptr + lw $23, caml_young_limit /* Say that we are back into Caml code */ sw $0, caml_last_return_address /* Call the Caml code */ @@ -270,7 +270,7 @@ $106: sw $24, caml_gc_regs addu $sp, $sp, 16 /* Update allocation pointer */ - sw $22, young_ptr + sw $22, caml_young_ptr /* Reload callee-save registers and return */ ld $31, 0x88($sp) ld $16, 0x0($sp) @@ -303,15 +303,15 @@ $105: /* Raise an exception from C */ - .globl raise_caml_exception - .ent raise_caml_exception -raise_caml_exception: + .globl caml_raise_exception + .ent caml_raise_exception +caml_raise_exception: /* Setup $gp, discarding caller's $gp (we won't return) */ - .cpsetup $25, $24, raise_caml_exception + .cpsetup $25, $24, caml_raise_exception /* Branch to exn handler */ move $2, $4 - lw $22, young_ptr - lw $23, young_limit + lw $22, caml_young_ptr + lw $23, caml_young_limit lw $sp, caml_exception_pointer lw $30, 0($sp) lw $24, 4($sp) @@ -319,27 +319,27 @@ raise_caml_exception: addu $sp, $sp, 16 j $24 - .end raise_caml_exception + .end caml_raise_exception /* Callback from C to Caml */ - .globl callback_exn - .ent callback_exn -callback_exn: + .globl caml_callback_exn + .ent caml_callback_exn +caml_callback_exn: subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, callback_exn + .cpsetup $25, 0x80, caml_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 + .end caml_callback_exn - .globl callback2_exn - .ent callback2_exn -callback2_exn: + .globl caml_callback2_exn + .ent caml_callback2_exn +caml_callback2_exn: subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, callback2_exn + .cpsetup $25, 0x80, caml_callback2_exn /* Initial shuffling of arguments */ move $10, $4 /* closure */ move $8, $5 /* first argument */ @@ -347,13 +347,13 @@ callback2_exn: la $24, caml_apply2 /* code pointer */ b $103 - .end callback2_exn + .end caml_callback2_exn - .globl callback3_exn - .ent callback3_exn -callback3_exn: + .globl caml_callback3_exn + .ent caml_callback3_exn +caml_callback3_exn: subu $sp, $sp, 0x90 - .cpsetup $25, 0x80, callback3_exn + .cpsetup $25, 0x80, caml_callback3_exn /* Initial shuffling of arguments */ move $11, $4 /* closure */ move $8, $5 /* first argument */ @@ -362,24 +362,24 @@ callback3_exn: la $24, caml_apply3 /* code pointer */ b $103 - .end callback3_exn + .end caml_callback3_exn -/* Glue code to call array_bound_error */ +/* Glue code to call [caml_array_bound_error] */ - .globl caml_array_bound_error - .ent caml_array_bound_error + .globl caml_ml_array_bound_error + .ent caml_ml_array_bound_error -caml_array_bound_error: +caml_ml_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 + .cpsetup $25, $24, caml_ml_array_bound_error + la $24, caml_array_bound_error jal caml_c_call /* never returns */ - .end caml_array_bound_error + .end caml_ml_array_bound_error .rdata - .globl system__frametable -system__frametable: + .globl caml_system__frametable +caml_system__frametable: .word 1 /* one descriptor */ .word $104 /* return address into callback */ .half -1 /* negative frame size => use callback link */ diff --git a/asmrun/power-aix.S b/asmrun/power-aix.S index 14809a03..b8afea6f 100644 --- a/asmrun/power-aix.S +++ b/asmrun/power-aix.S @@ -11,7 +11,7 @@ #* * #********************************************************************* -# $Id: power-aix.S,v 1.12 2003/06/20 15:17:52 doligez Exp $ +# $Id: power-aix.S,v 1.15 2004/01/03 12:51:19 doligez Exp $ .csect .text[PR] @@ -37,7 +37,7 @@ addi 0, 1, 8*32 + 64 stw 0, 0(11) # Save current allocation pointer for debugging purposes - lwz 11, L..young_ptr(2) + lwz 11, L..caml_young_ptr(2) stw 31, 0(11) # Save exception pointer (if e.g. a sighandler raises) lwz 11, L..caml_exception_pointer(2) @@ -100,12 +100,12 @@ stfdu 30, 8(11) stfdu 31, 8(11) # Call the GC - bl .garbage_collection + bl .caml_garbage_collection or 0, 0, 0 # Reload new allocation pointer and allocation limit - lwz 11, L..young_ptr(2) + lwz 11, L..caml_young_ptr(2) lwz 31, 0(11) - lwz 11, L..young_limit(2) + lwz 11, L..caml_young_limit(2) lwz 30, 0(11) # Restore all regs used by the code generator addi 11, 1, 8*32 + 64 - 4 @@ -192,14 +192,14 @@ 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 27, L..caml_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, + # Return address is in 25, RTOC is in 26, pointer to caml_young_ptr in 27, # pointer to caml_last_return_address is in 24 # Call the function (descriptor in 11) lwz 0, 0(11) @@ -213,7 +213,7 @@ # Restore RTOC mr 2, 26 # Reload allocation pointer - lwz 31, 0(27) # 27 still points to young_ptr + lwz 31, 0(27) # 27 still points to caml_young_ptr # Say we are back into Caml code li 12, 0 stw 12, 0(24) # 24 still points to caml_last_return_address @@ -222,12 +222,12 @@ #### Raise an exception from C - .globl .raise_caml_exception -.raise_caml_exception: + .globl .caml_raise_exception +.caml_raise_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 5, L..caml_young_ptr(2) + lwz 6, L..caml_young_limit(2) lwz 1, 0(4) lwz 31, 0(5) lwz 30, 0(6) @@ -250,7 +250,7 @@ .caml_start_program: lwz 11, L..caml_program(2) -#### Code shared between caml_start_program and callback* +#### Code shared between caml_start_program and caml_callback* L..102: mflr 0 @@ -320,8 +320,8 @@ L..103: stw 2, 20(1) mr 29, 1 # Reload allocation pointers - lwz 9, L..young_ptr(2) - lwz 10, L..young_limit(2) + lwz 9, L..caml_young_ptr(2) + lwz 10, L..caml_young_limit(2) lwz 31, 0(9) lwz 30, 0(10) # Say we are back into Caml code @@ -354,7 +354,7 @@ L..106: stw 9, 0(12) addi 1, 1, 32 # Update allocation pointer - lwz 11, L..young_ptr(2) + lwz 11, L..caml_young_ptr(2) stw 31, 0(11) # Deallocate stack frame addi 1, 1, 288 @@ -412,8 +412,8 @@ L..104: #### Callback from C to Caml - .globl .callback_exn -.callback_exn: + .globl .caml_callback_exn +.caml_callback_exn: # Initial shuffling of arguments mr 0, 3 # Closure mr 3, 4 # Argument @@ -421,8 +421,8 @@ L..104: lwz 11, 0(4) # Code pointer b L..102 - .globl .callback2_exn -.callback2_exn: + .globl .caml_callback2_exn +.caml_callback2_exn: mr 0, 3 # Closure mr 3, 4 # First argument mr 4, 5 # Second argument @@ -430,8 +430,8 @@ L..104: lwz 11, L..caml_apply2(2) b L..102 - .globl .callback3_exn -.callback3_exn: + .globl .caml_callback3_exn +.caml_callback3_exn: mr 0, 3 # Closure mr 3, 4 # First argument mr 4, 5 # Second argument @@ -443,8 +443,8 @@ L..104: #### Frame table .csect .data[RW] - .globl system__frametable -system__frametable: + .globl caml_system__frametable +caml_system__frametable: .long 1 # one descriptor .long L..105 + 4 # return address into callback .short -1 # negative size count => use callback link @@ -453,10 +453,10 @@ system__frametable: #### TOC entries .toc -L..young_limit: - .tc young_limit[TC], young_limit -L..young_ptr: - .tc young_ptr[TC], young_ptr +L..caml_young_limit: + .tc caml_young_limit[TC], caml_young_limit +L..caml_young_ptr: + .tc caml_young_ptr[TC], caml_young_ptr L..caml_bottom_of_stack: .tc caml_bottom_of_stack[TC], caml_bottom_of_stack L..caml_last_return_address: @@ -487,27 +487,27 @@ caml_call_gc: 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_raise_exception + .csect caml_raise_exception[DS] +caml_raise_exception: + .long .caml_raise_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 caml_callback_exn + .csect caml_callback_exn[DS] +caml_callback_exn: + .long .caml_callback_exn, TOC[tc0], 0 - .globl callback2_exn - .csect callback2_exn[DS] -callback2_exn: - .long .callback2_exn, TOC[tc0], 0 + .globl caml_callback2_exn + .csect caml_callback2_exn[DS] +caml_callback2_exn: + .long .caml_callback2_exn, TOC[tc0], 0 - .globl callback3_exn - .csect callback3_exn[DS] -callback3_exn: - .long .callback3_exn, TOC[tc0], 0 + .globl caml_callback3_exn + .csect caml_callback3_exn[DS] +caml_callback3_exn: + .long .caml_callback3_exn, TOC[tc0], 0 diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S index 6e9cf8be..c890f46d 100644 --- a/asmrun/power-elf.S +++ b/asmrun/power-elf.S @@ -11,7 +11,7 @@ /* */ /*********************************************************************/ -/* $Id: power-elf.S,v 1.15 2003/06/20 15:17:52 doligez Exp $ */ +/* $Id: power-elf.S,v 1.18 2004/01/03 12:51:19 doligez Exp $ */ #define Addrglobal(reg,glob) \ addis reg, 0, glob@ha; \ @@ -43,7 +43,7 @@ caml_call_gc: addi 0, 1, 8*32 + 32 Storeglobal(0, caml_gc_regs, 11) /* Save current allocation pointer for debugging purposes */ - Storeglobal(31, young_ptr, 11) + Storeglobal(31, caml_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 */ @@ -104,10 +104,10 @@ caml_call_gc: stfdu 30, 8(11) stfdu 31, 8(11) /* Call the GC */ - bl garbage_collection + bl caml_garbage_collection /* Reload new allocation pointer and allocation limit */ - Loadglobal(31, young_ptr, 11) - Loadglobal(30, young_limit, 11) + Loadglobal(31, caml_young_ptr, 11) + Loadglobal(30, caml_young_limit, 11) /* Restore all regs used by the code generator */ addi 11, 1, 8*32 + 32 - 4 lwzu 3, 4(11) @@ -190,15 +190,15 @@ caml_c_call: 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(31, caml_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) + Loadglobal(31, caml_young_ptr, 11) + Loadglobal(30, caml_young_limit, 11) /* Say we are back into Caml code */ li 12, 0 Storeglobal(12, caml_last_return_address, 11) @@ -207,13 +207,13 @@ caml_c_call: /* Raise an exception from C */ - .globl raise_caml_exception - .type raise_caml_exception, @function -raise_caml_exception: + .globl caml_raise_exception + .type caml_raise_exception, @function +caml_raise_exception: /* Reload Caml global registers */ Loadglobal(1, caml_exception_pointer, 11) - Loadglobal(31, young_ptr, 11) - Loadglobal(30, young_limit, 11) + Loadglobal(31, caml_young_ptr, 11) + Loadglobal(30, caml_young_limit, 11) /* Say we are back into Caml code */ li 0, 0 Storeglobal(0, caml_last_return_address, 11) @@ -232,7 +232,7 @@ raise_caml_exception: caml_start_program: Addrglobal(12, caml_program) -/* Code shared between caml_start_program and callback */ +/* Code shared between caml_start_program and caml_callback */ .L102: /* Allocate and link stack frame */ stwu 1, -256(1) @@ -298,8 +298,8 @@ caml_start_program: stw 11, 4(1) mr 29, 1 /* Reload allocation pointers */ - Loadglobal(31, young_ptr, 11) - Loadglobal(30, young_limit, 11) + Loadglobal(31, caml_young_ptr, 11) + Loadglobal(30, caml_young_limit, 11) /* Say we are back into Caml code */ li 0, 0 Storeglobal(0, caml_last_return_address, 11) @@ -321,7 +321,7 @@ caml_start_program: Storeglobal(11, caml_gc_regs, 12) addi 1, 1, 16 /* Update allocation pointer */ - Storeglobal(31, young_ptr, 11) + Storeglobal(31, caml_young_ptr, 11) /* Restore callee-save registers */ addi 11, 1, 16-4 lwzu 14, 4(11) @@ -377,9 +377,9 @@ caml_start_program: /* Callback from C to Caml */ - .globl callback_exn - .type callback_exn, @function -callback_exn: + .globl caml_callback_exn + .type caml_callback_exn, @function +caml_callback_exn: /* Initial shuffling of arguments */ mr 0, 3 /* Closure */ mr 3, 4 /* Argument */ @@ -387,9 +387,9 @@ callback_exn: lwz 12, 0(4) /* Code pointer */ b .L102 - .globl callback2_exn - .type callback2_exn, @function -callback2_exn: + .globl caml_callback2_exn + .type caml_callback2_exn, @function +caml_callback2_exn: mr 0, 3 /* Closure */ mr 3, 4 /* First argument */ mr 4, 5 /* Second argument */ @@ -397,9 +397,9 @@ callback2_exn: Addrglobal(12, caml_apply2) b .L102 - .globl callback3_exn - .type callback3_exn, @function -callback3_exn: + .globl caml_callback3_exn + .type caml_callback3_exn, @function +caml_callback3_exn: mr 0, 3 /* Closure */ mr 3, 4 /* First argument */ mr 4, 5 /* Second argument */ @@ -411,9 +411,9 @@ callback3_exn: /* Frame table */ .section ".data" - .globl system__frametable - .type system__frametable, @object -system__frametable: + .globl caml_system__frametable + .type caml_system__frametable, @object +caml_system__frametable: .long 1 /* one descriptor */ .long .L105 + 4 /* return address into callback */ .short -1 /* negative size count => use callback link */ diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S index 7017d736..338010cb 100644 --- a/asmrun/power-rhapsody.S +++ b/asmrun/power-rhapsody.S @@ -11,7 +11,7 @@ /* */ /*********************************************************************/ -/* $Id: power-rhapsody.S,v 1.9 2003/06/20 15:17:52 doligez Exp $ */ +/* $Id: power-rhapsody.S,v 1.13 2004/02/22 14:56:25 xleroy Exp $ */ .macro Addrglobal /* reg, glob */ addis $0, 0, ha16($1) @@ -45,7 +45,7 @@ _caml_call_gc: addi r0, r1, 8*32 + 32 Storeglobal r0, _caml_gc_regs, r11 /* Save current allocation pointer for debugging purposes */ - Storeglobal r31, _young_ptr, r11 + Storeglobal r31, _caml_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 */ @@ -106,10 +106,10 @@ _caml_call_gc: stfdu f30, 8(r11) stfdu f31, 8(r11) /* Call the GC */ - bl _garbage_collection + bl _caml_garbage_collection /* Reload new allocation pointer and allocation limit */ - Loadglobal r31, _young_ptr, r11 - Loadglobal r30, _young_limit, r11 + Loadglobal r31, _caml_young_ptr, r11 + Loadglobal r30, _caml_young_limit, r11 /* Restore all regs used by the code generator */ addi r11, r1, 8*32 + 32 - 4 lwzu r3, 4(r11) @@ -186,20 +186,20 @@ _caml_c_call: /* Save return address */ mflr r25 /* Get ready to call C function (address in 11) */ - mtlr r11 + mtctr 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 r31, _caml_young_ptr, r11 Storeglobal r29, _caml_exception_pointer, r11 /* Call the function (address in link register) */ - blrl + bctrl /* 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 + Loadglobal r31, _caml_young_ptr, r11 + Loadglobal r30, _caml_young_limit, r11 /* Say we are back into Caml code */ li r12, 0 Storeglobal r12, _caml_last_return_address, r11 @@ -208,12 +208,12 @@ _caml_c_call: /* Raise an exception from C */ - .globl _raise_caml_exception -_raise_caml_exception: + .globl _caml_raise_exception +_caml_raise_exception: /* Reload Caml global registers */ Loadglobal r1, _caml_exception_pointer, r11 - Loadglobal r31, _young_ptr, r11 - Loadglobal r30, _young_limit, r11 + Loadglobal r31, _caml_young_ptr, r11 + Loadglobal r30, _caml_young_limit, r11 /* Say we are back into Caml code */ li r0, 0 Storeglobal r0, _caml_last_return_address, r11 @@ -231,7 +231,7 @@ _raise_caml_exception: _caml_start_program: Addrglobal r12, _caml_program -/* Code shared between caml_start_program and callback */ +/* Code shared between caml_start_program and caml_callback */ L102: /* Allocate and link stack frame */ stwu r1, -256(r1) @@ -297,15 +297,15 @@ L103: stw r11, 4(r1) mr r29, r1 /* Reload allocation pointers */ - Loadglobal r31, _young_ptr, r11 - Loadglobal r30, _young_limit, r11 + Loadglobal r31, _caml_young_ptr, r11 + Loadglobal r30, _caml_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 + mtctr r12 L105: - blrl + bctrl /* Pop the trap frame, restoring caml_exception_pointer */ lwz r9, 4(r1) Storeglobal r9, _caml_exception_pointer, r11 @@ -320,7 +320,7 @@ L106: Storeglobal r11, _caml_gc_regs, r12 addi r1, r1, 16 /* Update allocation pointer */ - Storeglobal r31, _young_ptr, r11 + Storeglobal r31, _caml_young_ptr, r11 /* Restore callee-save registers */ addi r11, r1, 16-4 lwzu r14, 4(r11) @@ -376,8 +376,8 @@ L104: /* Callback from C to Caml */ - .globl _callback_exn -_callback_exn: + .globl _caml_callback_exn +_caml_callback_exn: /* Initial shuffling of arguments */ mr r0, r3 /* Closure */ mr r3, r4 /* Argument */ @@ -385,8 +385,8 @@ _callback_exn: lwz r12, 0(r4) /* Code pointer */ b L102 - .globl _callback2_exn -_callback2_exn: + .globl _caml_callback2_exn +_caml_callback2_exn: mr r0, r3 /* Closure */ mr r3, r4 /* First argument */ mr r4, r5 /* Second argument */ @@ -394,8 +394,8 @@ _callback2_exn: Addrglobal r12, _caml_apply2 b L102 - .globl _callback3_exn -_callback3_exn: + .globl _caml_callback3_exn +_caml_callback3_exn: mr r0, r3 /* Closure */ mr r3, r4 /* First argument */ mr r4, r5 /* Second argument */ @@ -407,8 +407,8 @@ _callback3_exn: /* Frame table */ .const - .globl _system__frametable -_system__frametable: + .globl _caml_system__frametable +_caml_system__frametable: .long 1 /* one descriptor */ .long L105 + 4 /* return address into callback */ .short -1 /* negative size count => use callback link */ diff --git a/asmrun/roots.c b/asmrun/roots.c index 14d5f271..200bdbf9 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: roots.c,v 1.34 2002/01/20 22:20:51 doligez Exp $ */ +/* $Id: roots.c,v 1.37 2004/01/02 19:22:19 doligez Exp $ */ /* To walk the memory roots for garbage collection */ @@ -27,9 +27,9 @@ /* Roots registered from C functions */ -struct caml__roots_block *local_roots = NULL; +struct caml__roots_block *caml_local_roots = NULL; -void (*scan_roots_hook) (scanning_action) = NULL; +void (*caml_scan_roots_hook) (scanning_action) = NULL; /* The hashtable of frame descriptors */ @@ -65,7 +65,7 @@ static void init_frame_descriptors(void) /* Allocate the hash table */ frame_descriptors = - (frame_descr **) stat_alloc(tblsize * sizeof(frame_descr *)); + (frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *)); for (i = 0; i < tblsize; i++) frame_descriptors[i] = NULL; frame_descriptors_mask = tblsize - 1; @@ -97,9 +97,9 @@ 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 +/* Call [caml_oldify_one] on (at least) all the roots that point to the minor heap. */ -void oldify_local_roots (void) +void caml_oldify_local_roots (void) { char * sp; unsigned long retaddr; @@ -175,7 +175,7 @@ void oldify_local_roots (void) } } /* Local C roots */ - for (lr = local_roots; lr != NULL; lr = lr->next) { + for (lr = caml_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]); @@ -188,19 +188,19 @@ void oldify_local_roots (void) Oldify (gr->root); } /* Finalised values */ - final_do_young_roots (&oldify_one); + caml_final_do_young_roots (&caml_oldify_one); /* Hook */ - if (scan_roots_hook != NULL) (*scan_roots_hook)(oldify_one); + if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(caml_oldify_one); } /* Call [darken] on all roots */ -void darken_all_roots (void) +void caml_darken_all_roots (void) { - do_roots (darken); + caml_do_roots (caml_darken); } -void do_roots (scanning_action f) +void caml_do_roots (scanning_action f) { int i, j; value glob; @@ -214,21 +214,21 @@ void do_roots (scanning_action f) } /* 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); + caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address, + caml_gc_regs, caml_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); + caml_final_do_strong_roots (f); /* Hook */ - if (scan_roots_hook != NULL) (*scan_roots_hook)(f); + if (caml_scan_roots_hook != NULL) (*caml_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) +void caml_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; diff --git a/asmrun/signals.c b/asmrun/signals.c index 089c6ae9..e5e23df5 100644 --- a/asmrun/signals.c +++ b/asmrun/signals.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: signals.c,v 1.74 2003/07/17 15:11:03 xleroy Exp $ */ +/* $Id: signals.c,v 1.81 2004/06/19 16:13:32 xleroy Exp $ */ #include #include @@ -33,15 +33,15 @@ #include #endif -extern char * code_area_start, * code_area_end; +extern char * caml_code_area_start, * caml_code_area_end; #define In_code_area(pc) \ - ((char *)(pc) >= code_area_start && (char *)(pc) <= code_area_end) + ((char *)(pc) >= caml_code_area_start && (char *)(pc) <= caml_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) +extern sighandler caml_win32_signal(int sig, sighandler action); +#define signal(sig,act) caml_win32_signal(sig,act) #endif #if defined(TARGET_power) && defined(SYS_rhapsody) @@ -62,7 +62,7 @@ extern sighandler win32_signal(int sig, sighandler action); ctx_version = 2; } }else{ - fatal_error ("cannot determine SIGCONTEXT format"); + caml_fatal_error ("cannot determine SIGCONTEXT format"); } } @@ -109,30 +109,18 @@ extern sighandler win32_signal(int sig, sighandler action); #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; +volatile int caml_async_signal_mode = 0; +volatile int caml_pending_signal = 0; +volatile int caml_force_major_slice = 0; +value caml_signal_handlers = 0; +void (*caml_enter_blocking_section_hook)() = NULL; +void (*caml_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) +void caml_execute_signal(int signal_number, int in_signal_handler) { value res; #ifdef POSIX_SIGNALS @@ -143,8 +131,8 @@ void execute_signal(int signal_number, int in_signal_handler) 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))); + res = caml_callback_exn(Field(caml_signal_handlers, signal_number), + Val_int(rev_convert_signal_number(signal_number))); #ifdef POSIX_SIGNALS if (! in_signal_handler) { /* Restore the original signal mask */ @@ -155,155 +143,135 @@ void execute_signal(int signal_number, int in_signal_handler) sigprocmask(SIG_SETMASK, &sigs, NULL); } #endif - if (Is_exception_result(res)) mlraise(Extract_exception(res)); + if (Is_exception_result(res)) caml_raise(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 + Hence [caml_garbage_collection] must not be called from regular C code + (e.g. the [caml_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], + Only generated assembly code can call [caml_garbage_collection], via the caml_call_gc assembly stubs. */ -void garbage_collection(void) +void caml_garbage_collection(void) { int sig; - if (young_ptr < young_start || force_major_slice) minor_collection(); + if (caml_young_ptr < caml_young_start || caml_force_major_slice){ + caml_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); + sig = caml_pending_signal; + caml_pending_signal = 0; + caml_young_limit = caml_young_start; + if (sig) caml_execute_signal(sig, 0); } /* Trigger a garbage collection as soon as possible */ -void urge_major_slice (void) +void caml_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. */ + caml_force_major_slice = 1; + caml_young_limit = caml_young_end; + /* This is only moderately effective on ports that cache [caml_young_limit] + in a register, since [caml_modify] is called directly, not through + [caml_c_call], so it may take a while before the register is reloaded + from [caml_young_limit]. */ } -void enter_blocking_section(void) +void caml_enter_blocking_section(void) { int sig; while (1){ - Assert (!async_signal_mode); + Assert (!caml_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; + sig = caml_pending_signal; + caml_pending_signal = 0; + caml_young_limit = caml_young_start; + if (sig) caml_execute_signal(sig, 0); + caml_async_signal_mode = 1; + if (!caml_pending_signal) break; + caml_async_signal_mode = 0; + } + if (caml_enter_blocking_section_hook != NULL){ + caml_enter_blocking_section_hook(); } - 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) +void caml_leave_blocking_section(void) { - 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; + if (caml_leave_blocking_section_hook != NULL){ + caml_leave_blocking_section_hook(); + } + Assert(caml_async_signal_mode); + caml_async_signal_mode = 0; } -#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) +static 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) +static 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) +static 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) +static 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) +static void handle_signal(int sig, int code, void * context) #else -void handle_signal(int sig) +static void handle_signal(int sig) #endif { #if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) signal(sig, handle_signal); #endif - if (async_signal_mode) { + if (caml_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(); + caml_leave_blocking_section(); + caml_execute_signal(sig, 1); + caml_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. + caml_pending_signal = sig; + caml_young_limit = caml_young_end; + /* Some ports cache [caml_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; + context->sc_regs[14] = (long) caml_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; + context->sc_regs[23] = (int) caml_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; + context->regs->gpr[30] = (unsigned long) caml_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; + CONTEXT_GPR(context, 30) = (unsigned long) caml_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; + context->sc_frame.fixreg[30] = (unsigned long) caml_young_limit; } #endif #if defined(TARGET_sparc) && defined(SYS_solaris) @@ -311,7 +279,7 @@ void handle_signal(int sig) 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; + ((long *)(gregs[REG_SP]))[7] = (long) caml_young_limit; } } #endif @@ -388,7 +356,7 @@ static int posix_signals[] = { SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGVTALRM, SIGPROF }; -int convert_signal_number(int signo) +int caml_convert_signal_number(int signo) { if (signo < 0 && signo >= -(sizeof(posix_signals) / sizeof(int))) return posix_signals[-signo-1]; @@ -408,7 +376,7 @@ static int rev_convert_signal_number(int signo) #define NSIG 64 #endif -value install_signal_handler(value signal_number, value action) /* ML */ +value caml_install_signal_handler(value signal_number, value action) /* ML */ { CAMLparam2 (signal_number, action); int sig; @@ -418,9 +386,9 @@ value install_signal_handler(value signal_number, value action) /* ML */ #endif CAMLlocal1 (res); - sig = convert_signal_number(Int_val(signal_number)); + sig = caml_convert_signal_number(Int_val(signal_number)); if (sig < 0 || sig >= NSIG) - invalid_argument("Sys.signal: unavailable signal"); + caml_invalid_argument("Sys.signal: unavailable signal"); switch(action) { case Val_int(0): /* Signal_default */ act = SIG_DFL; @@ -440,26 +408,26 @@ value install_signal_handler(value signal_number, value action) /* ML */ #else sigact.sa_flags = 0; #endif - if (sigaction(sig, &sigact, &oldsigact) == -1) sys_error(NO_ARG); + if (sigaction(sig, &sigact, &oldsigact) == -1) caml_sys_error(NO_ARG); oldact = oldsigact.sa_handler; #else oldact = signal(sig, act); - if (oldact == SIG_ERR) sys_error(NO_ARG); + if (oldact == SIG_ERR) caml_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); + res = caml_alloc_small(1, 0); /* Signal_handle */ + Field(res, 0) = Field(caml_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); + if (caml_signal_handlers == 0) { + caml_signal_handlers = caml_alloc(NSIG, 0); + caml_register_global_root(&caml_signal_handlers); } - modify(&Field(signal_handlers, sig), Field(action, 0)); + caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0)); } CAMLreturn (res); } @@ -480,11 +448,12 @@ static void trap_handler(int sig, int code, 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 */ + /* Recover [caml_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(); + caml_young_ptr = (char *) sp[6]; + caml_array_bound_error(); } #endif @@ -498,44 +467,31 @@ static void trap_handler(int sig, siginfo_t * info, void * context) info->si_code); exit(100); } - /* Recover young_ptr and caml_exception_pointer from the %l5 and %l6 regs */ + /* Recover [caml_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(); + caml_young_ptr = (char *) sp[6]; + caml_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(); + /* TODO: recover registers from context and call [caml_array_bound_error] */ + caml_fatal_error("Fatal error: out-of-bound access in array or string\n"); } #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 */ + /* Recover [caml_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(); + caml_young_ptr = (char *) context->regs->gpr[31]; + caml_array_bound_error(); } #endif @@ -547,20 +503,22 @@ static void trap_handler(int sig, int code, STRUCT_SIGCONTEXT * context) sigemptyset(&mask); sigaddset(&mask, SIGTRAP); sigprocmask(SIG_UNBLOCK, &mask, NULL); - /* Recover young_ptr and caml_exception_pointer from registers 31 and 29 */ + /* Recover [caml_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(); + caml_young_ptr = (char *) CONTEXT_GPR(context, 31); + caml_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 */ + /* Recover [caml_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(); + caml_young_ptr = (char *) context->sc_frame.fixreg[31]; + caml_array_bound_error(); } #endif @@ -601,7 +559,7 @@ static int is_stack_overflow(char * fault_addr) static void segv_handler(int signo, struct sigcontext sc) { if (is_stack_overflow((char *) sc.cr2)) - raise_stack_overflow(); + caml_raise_stack_overflow(); } #endif @@ -609,7 +567,7 @@ static void segv_handler(int signo, struct sigcontext sc) static void segv_handler(int signo, siginfo_t * info, void * arg) { if (is_stack_overflow((char *) info->si_addr)) - raise_stack_overflow(); + caml_raise_stack_overflow(); } #endif @@ -617,7 +575,7 @@ static void segv_handler(int signo, siginfo_t * info, void * arg) /* Initialization of signal stuff */ -void init_signals(void) +void caml_init_signals(void) { /* Bound-check trap handling */ #if defined(TARGET_sparc) && \ @@ -646,8 +604,6 @@ void init_signals(void) 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 diff --git a/asmrun/sparc.S b/asmrun/sparc.S index 7a4ef5f0..e4cc282a 100644 --- a/asmrun/sparc.S +++ b/asmrun/sparc.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: sparc.S,v 1.20 2003/07/17 15:11:03 xleroy Exp $ */ +/* $Id: sparc.S,v 1.24 2004/02/17 12:30:11 xleroy Exp $ */ /* Asm part of the runtime system for the Sparc processor. */ /* Must be preprocessed by cpp */ @@ -22,53 +22,53 @@ .common _caml_required_size, 4, "bss" -#define Young_limit _young_limit -#define Young_ptr _young_ptr +#define Caml_young_limit _caml_young_limit +#define Caml_young_ptr _caml_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_allocN _caml_allocN #define Caml_call_gc _caml_call_gc -#define Garbage_collection _garbage_collection +#define Caml_garbage_collection _caml_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_raise_exception _caml_raise_exception +#define Caml_callback_exn _caml_callback_exn +#define Caml_callback2_exn _caml_callback2_exn +#define Caml_callback3_exn _caml_callback3_exn #define Caml_apply2 _caml_apply2 #define Caml_apply3 _caml_apply3 -#define Mlraise _mlraise -#define System_frametable _system__frametable +#define Caml_raise _caml_raise +#define Caml_system__frametable _caml_system__frametable #else .common caml_required_size, 4, 4 -#define Young_limit young_limit -#define Young_ptr young_ptr +#define Caml_young_limit caml_young_limit +#define Caml_young_ptr caml_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_allocN caml_allocN #define Caml_call_gc caml_call_gc -#define Garbage_collection garbage_collection +#define Caml_garbage_collection caml_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_raise_exception caml_raise_exception +#define Caml_callback_exn caml_callback_exn +#define Caml_callback2_exn caml_callback2_exn +#define Caml_callback3_exn caml_callback3_exn #define Caml_apply2 caml_apply2 #define Caml_apply3 caml_apply3 -#define Mlraise mlraise -#define System_frametable system__frametable +#define Caml_raise caml_raise +#define Caml_system__frametable caml_system__frametable #endif @@ -87,11 +87,11 @@ /* Allocation functions */ .text - .global Caml_alloc + .global Caml_allocN .global Caml_call_gc /* Required size in %g2 */ -Caml_alloc: +Caml_allocN: #ifdef INDIRECT_LIMIT ld [Alloc_limit], %g1 sub Alloc_ptr, %g2, Alloc_ptr @@ -113,7 +113,7 @@ Caml_call_gc: /* Save exception pointer if GC raises */ Store(Exn_ptr, Caml_exception_pointer) /* Save current allocation pointer for debugging purposes */ - Store(Alloc_ptr, Young_ptr) + Store(Alloc_ptr, Caml_young_ptr) /* Record lowest stack address */ Store(%sp, Caml_bottom_of_stack) /* Record last return address */ @@ -160,7 +160,7 @@ L100: add %sp, 96 + 15*8, %g2 std %f26, [%g1 + 0x68] std %f28, [%g1 + 0x70] /* Call the garbage collector */ - call Garbage_collection + call Caml_garbage_collection nop /* Restore all regs used by the code generator */ add %sp, 96 + 15*8, %g2 @@ -200,7 +200,7 @@ L100: add %sp, 96 + 15*8, %g2 ldd [%g1 + 0x68], %f26 ldd [%g1 + 0x70], %f28 /* Reload alloc ptr */ - Load(Young_ptr, Alloc_ptr) + Load(Caml_young_ptr, Alloc_ptr) /* Allocate space for block */ Load(Caml_required_size, %g2) #ifdef INDIRECT_LIMIT @@ -208,7 +208,7 @@ L100: add %sp, 96 + 15*8, %g2 sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, %g1 /* Check that we have enough free space */ #else - Load(Young_limit,Alloc_limit) + Load(Caml_young_limit,Alloc_limit) sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, Alloc_limit #endif @@ -229,17 +229,17 @@ Caml_c_call: Store(%o7, Caml_last_return_address) /* Save the exception handler and alloc pointer */ Store(Exn_ptr, Caml_exception_pointer) - sethi %hi(Young_ptr), %g1 + sethi %hi(Caml_young_ptr), %g1 /* Call the C function */ call %g2 - st Alloc_ptr, [%g1 + %lo(Young_ptr)] /* in delay slot */ + st Alloc_ptr, [%g1 + %lo(Caml_young_ptr)] /* in delay slot */ /* Reload return address */ Load(Caml_last_return_address, %o7) /* Reload alloc pointer */ - sethi %hi(Young_ptr), %g1 + sethi %hi(Caml_young_ptr), %g1 /* Return to caller */ retl - ld [%g1 + %lo(Young_ptr)], Alloc_ptr /* in delay slot */ + ld [%g1 + %lo(Caml_young_ptr)], Alloc_ptr /* in delay slot */ /* Start the Caml program */ @@ -250,7 +250,7 @@ Caml_start_program: /* Address of code to call */ Address(Caml_program, %l2) - /* Code shared with callback* */ + /* Code shared with caml_callback* */ L108: /* Set up a callback link on the stack. */ sub %sp, 16, %sp @@ -270,11 +270,11 @@ L111: sub %sp, 8, %sp st Exn_ptr, [%sp + 100] mov %sp, Exn_ptr /* Reload allocation pointers */ - Load(Young_ptr, Alloc_ptr) + Load(Caml_young_ptr, Alloc_ptr) #ifdef INDIRECT_LIMIT - Address(Young_limit, Alloc_limit) + Address(Caml_young_limit, Alloc_limit) #else - Load(Young_limit, Alloc_limit) + Load(Caml_young_limit, Alloc_limit) #endif /* Call the Caml code */ L109: call %l2 @@ -292,7 +292,7 @@ L112: ld [%sp + 96], %l0 Store(%l2, Caml_gc_regs) add %sp, 16, %sp /* Save allocation pointer */ - Store(Alloc_ptr, Young_ptr) + Store(Alloc_ptr, Caml_young_ptr) /* Reload callee-save registers and return */ ret restore %o0, 0, %o0 /* copy %o0 in this window to caller's %o0 */ @@ -305,8 +305,8 @@ L110: /* Raise an exception from C */ - .global Raise_caml_exception -Raise_caml_exception: + .global Caml_raise_exception +Caml_raise_exception: /* Save exception bucket in a register outside the reg windows */ mov %o0, %g2 /* Load exception pointer in a register outside the reg windows */ @@ -321,11 +321,11 @@ L106: restore nop L107: /* Reload allocation registers */ - Load(Young_ptr, Alloc_ptr) + Load(Caml_young_ptr, Alloc_ptr) #ifdef INDIRECT_LIMIT - Address(Young_limit, Alloc_limit) + Address(Caml_young_limit, Alloc_limit) #else - Load(Young_limit, Alloc_limit) + Load(Caml_young_limit, Alloc_limit) #endif /* Branch to exception handler */ mov %g3, %sp @@ -338,8 +338,8 @@ L107: /* Callbacks C -> ML */ - .global Callback_exn -Callback_exn: + .global Caml_callback_exn +Caml_callback_exn: /* Save callee-save registers and return address */ save %sp, -96, %sp /* Initial shuffling of arguments */ @@ -349,8 +349,8 @@ Callback_exn: b L108 ld [%g1], %l2 /* code pointer */ - .global Callback2_exn -Callback2_exn: + .global Caml_callback2_exn +Caml_callback2_exn: /* Save callee-save registers and return address */ save %sp, -104, %sp /* Initial shuffling of arguments */ @@ -362,8 +362,8 @@ Callback2_exn: b L108 or %l2, %lo(Caml_apply2), %l2 - .global Callback3_exn -Callback3_exn: + .global Caml_callback3_exn +Caml_callback3_exn: /* Save callee-save registers and return address */ save %sp, -104, %sp /* Initial shuffling of arguments */ @@ -381,18 +381,18 @@ Callback3_exn: #else .data #endif - .global System_frametable -System_frametable: + .global Caml_system__frametable +Caml_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_allocN, #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 + .type Caml_raise_exception, #function + .type Caml_system__frametable, #object #endif diff --git a/asmrun/stack.h b/asmrun/stack.h index b90d4cba..14debd9a 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -11,12 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: stack.h,v 1.27 2003/06/30 08:28:45 xleroy Exp $ */ +/* $Id: stack.h,v 1.28 2003/12/16 18:09:04 doligez Exp $ */ /* Machine-dependent interface with the asm code */ -#ifndef _stack_ -#define _stack_ +#ifndef CAML_STACK_H +#define CAML_STACK_H /* Macros to access the stack frame */ #ifdef TARGET_alpha @@ -102,4 +102,4 @@ extern long caml_globals_inited; extern long * caml_frametable[]; -#endif /* _stack_ */ +#endif /* CAML_STACK_H */ diff --git a/asmrun/startup.c b/asmrun/startup.c index 6c3cfba4..4232cf9b 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: startup.c,v 1.24 2003/06/16 12:31:12 xleroy Exp $ */ +/* $Id: startup.c,v 1.30 2004/01/02 19:22:19 doligez Exp $ */ /* Start-up code */ @@ -31,10 +31,10 @@ #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; +extern int caml_parser_trace; +header_t caml_atom_table[256]; +char * caml_static_data_start, * caml_static_data_end; +char * caml_code_area_start, * caml_code_area_end; /* Initialize the atom table and the static data and code area limits. */ @@ -56,9 +56,10 @@ 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); + for (i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); + minmax_table(caml_data_segments, + &caml_static_data_start, &caml_static_data_end); + minmax_table(caml_code_segments, &caml_code_area_start, &caml_code_area_end); } /* Configuration parameters and flags */ @@ -104,8 +105,8 @@ static void parse_camlrunparam(void) 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; + case 'v': scanmult (opt, &caml_verb_gc); break; + case 'p': caml_parser_trace = 1; break; } } } @@ -116,8 +117,8 @@ 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); +extern void caml_init_ieee_floats (void); +extern void caml_init_signals (void); void caml_main(char **argv) { @@ -127,29 +128,29 @@ void caml_main(char **argv) #endif value res; - init_ieee_floats(); - init_custom_operations(); + caml_init_ieee_floats(); + caml_init_custom_operations(); #ifdef DEBUG - verb_gc = 63; + caml_verb_gc = 63; #endif parse_camlrunparam(); - init_gc (minor_heap_init, heap_size_init, heap_chunk_init, - percent_free_init, max_percent_free_init); + caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, + percent_free_init, max_percent_free_init); init_atoms(); - init_signals(); + caml_init_signals(); exe_name = argv[0]; #ifdef __linux__ - if (executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) + if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) exe_name = proc_self_exe; #endif - sys_init(exe_name, argv); + caml_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)); + caml_fatal_uncaught_exception(Extract_exception(res)); } void caml_startup(char **argv) diff --git a/boot/ocamlc b/boot/ocamlc index db6172aac59c6fc71909e37b8d131faaa8ada689..297a2ace262809c45f1a4283d2654505ed03d88d 100755 GIT binary patch delta 260677 zcmb@v51dWa`aeEv@A?0KWai*7XU1SK7=Kd+BY*QJQxuh${0T*-(oIp0QYm7}##1RO zl}b@fb?&WhDwR;CD2kgYDus+FiZZ|Vd!Mz(KAXDt`+5EL%VX{5y`Ht!v!3;=KYN|E z_k8!@IbX~!x<6Z0JrEG}jLdsYv|Ho`{NyY7R22G$WuM zqExq~4u+7|NYK+D$|(@9zrt2pg+}KV&qBh^)s_uQuhN)1hli{hqqAB{OEz1LGK1 z9+%(9sr9vpcWO@kt^_?}ZH-%jyidgYt%dOu?Ym<2j8&9S+H^bOsly@=>t}+z`aNo` zO(;;*G7lDuGxOwNQcSYdJ@I^<=@W@f)Z?O9|z&aoLbg-ZVY=DH{9G3Z(jB zw4&62+EOth^$m5=Ohlax%GM$dAMo%w9zNH@H+FbyLb}!T^%FHUw7+AotM&b2gx5It zRv=@)y00Rs&VH4d0I&eW>jxyRgD_x~b@KK992}jLvFt+cgJ-=Q{$DztmB<5)0{sZ0 zEOTMgGHfH&&&T*iGpW0<$B^93i-(`*;cxfwH+%TW)~34t=ZkZvpD4Jyq493o5&r15#rta7!QA=hripE-&Lpb3)U96+LK_LhgWDOcY%c- zzPE?J%){U1;a{@(5vOXr!6QINbQk!Chp&eo;ErccbMyTx@-D74Ge3g?hk=qn<3Jpw zKD6R4#S~J}`O+!_1FLUD1^%y|;Inp*=#9JlD}wlcNHR;OP;H$6X z+!Yw@567(-Hd?9ADu$0)p#Yp1>%U|R^m8UMj_?gZy+9n*dEXzz%Ng~Zct0@CE~%i= zAm+o%ma`^}>wx^1kE5E!SNYm~h#1a8PA*KD3}To8a&j&$D^jYmEv;t5%p`Y4nl{fWUgCC5yx=+Xf7K9CAC+3WF3Uvx&=O8(S z;ntpOIsfx=l;bGQd!}bII_VjnTESGtMF$!=Vyuf(AJ+3q(AJ8z6W19HKEUl*P;-!> z@0qMBYRROetQg+zv8sFeDmG8*Z5VB1FixPqqrImzjNx=+j{+6rr#u#ijvRN>4E#U) zrh<%EL}i1xfMFPI)l4pwv#X4BX)_qhs_X~SRkG~=DbD{uoA`>B)6xxfmQ{31z#bx4 zlUuCfvSRDuTawi`R`IPx*2c0X*5(<>r-l&AH+=?dTYPK4dTnN1>x1bBtS7E-=#iK^lU`g^PMvl zG3@}zat?GbrY{6Wp8?+2b_S=QH~$O^(?N()_*P&}Vz5!?c=(_GfWlI;F4iYA*P8Vj zF&*3QM&K-%1u;L~r%2`eB%eyPDsKwNvX{*Grge2peI2p~b_cNs^5SfhUQuvoaf0px zchB#NyLI!~3E3xRF5sFIcNIqYd#cf7$p3&2$M8plER}gNOt&hxO-i95d4+Q>dLYhd zGy^O>nbqwC8V#b#Y{w~9sa2%LTT3l}BYK!yjzgg%H=$yyRj3**^oURoM`Vr_SX`un z)`-RaMz?$9%3N}@ENk(!%zJ=vg?6JW=JtxflI04E*}?_+*7uUGHb~`dhR;fUunEAl zZX7UjFf^7uh}Ei9{va3d;rk;GcEEl9L;1i<9vT6Yt$L_3<3r?44e4ceueatsT!gsw z4-druXDuzj|HVr=upe1khOvI^BSnT)0$Yuth&~y zX*sf>8E4c1@fn<|TY`A;zKN9ViVavtH`KL`hFW!F7Hk0ON#ivJQ6-YYx5s@m5Y?fZ z)9vjkMV8*3;FmESV(ZDwn=vHMtcb5LUXPEhPqQ6=brzX7A7^j`;i7Z@Ggo!4caye5H%2-3jusNF1` zk>9Fbe?r=Pq~hDqh1goW*tU5fmcc7YPeD$Z3BOzQHe?$MqU|nCjgmlgMtVHW#d|ur z(}NsuB2LWdIh1vJO&so>9>e^YFD<|{^iJ|lm*x;b9!+6AyEG$#orX0?meR9TK=!?7 zCRgm<@L;U8{2(D&#($br*P6LHxv8TDLyFrDjF82(2hqXfCG8y*sO>f#0r6tDX(Oed zCSitI-Rd&tz*KbVULeQOZ^1o9sT`GL1vx%3o;Z1@qE6Rxw6b}t@QpkfH5(o2^0$-4 zsE2Nq-Co5@gN%f_Ob7(8X4AL_1;<9j&M*ip+!tL>vN96tHC^@ppy(&FtRZi=l7oAb z;ww@=eLgx^fZTZ<_PE_Anx_pZ!~VD){f`!KFG&6g%yFz%h@;0-HWhu4HFhxKmjPpY zxUlh2K~Lv>{0s?0z>v;vP&T%s0Ee#|^&sKk3~6Sk5XyXH4O|}>)6mmXdwBS(JUlxt z65H;@TpcrXMTvArVw_YQ{Ifro+@z*UYFa|N-NPBji#?o^4dr;<<}vlPCo0BmpKhqz ztg0_Ns|^*t9Tp#@R_!bWlk}g?SaMYK`l`@~S&zgiR$;u)T2R#$OO8!d{qX-;Utzt{gGzzUwU6xp?3|**U(&99xla@8E53P%>yH zhz`u5fNQaZR&YT;`koV0*J{u$-F_e%)2gBB%_X0*thHB!_XR(MDBC0eV)tOfPn5#7 z$|q0!$7m?A&nKkIb3+r7t<>+YgGRycOM;KU3Qjvh+_s9FztIyv$-`gj;s4ZrKr7SP zzS6Da@DGD$6*b={YKli-BzP+CBv z{odiyvTIU$E=N7)$cxTEIv2DEbTQ~ItN4fEG34T`r9Vuw@8T`rk4t56D;1wH01>$$ zPJvt>uD1#g1~QhQ-tU37fT}=0TKj(-s}@-$`+Rl=G1jDg19hfv>~k{hyuVmyKcn_; z?fzoBpr)r4qzerq}Ht6!;QoE$CCwHx>aF~S|7Z!1a< z?ljb5tLWzfYunFtt?56vRbs9BxxjcZO42_{%Bnc{bGlLsD{2mpP-;fSh+j-YJycP8 zv@AB09e_$9pBnb@QqV?g&ma9z|AIezCD^6})>zie#I&;H&#t=C+y9&Zk>ZnBOjjH^ zISD;wajBZ1*1x)5rGb&{O694CrT7N)t-BYbOJhUbchPn%d}w>eA*O&&a`9uqQwt}) zn@4^v_MbTSI`PY-#!$s-X{gv#$CQlEN=Ua-_cc^evMNU9+sZ>aDpxA+Q2wTz7MPOb z*FMzuYJ{9R@o^JLN2jn~kc8sRK+#rpbijHGo%pSobgS8rbUAq* z9)rinsvZe(i02Zgg{+E&4e&@4tCp$_p-FKH+WsMv64eo?T$-fz^UYYS=DA|}RiWA} z9sDZKSY3kwIa_Y>t3|CJMdNJ8{@QNPAE2`^rQ8Yn7L<;GemZ*d8qf*QK=p4hd1QL1{X5+iD3sBJIRMX8r$Qg1aa#oaf1OLcGMYf%R+%W0XFcX|SU z9w5f21_ygZsva={mpqIp_mIB8!`}g(6?CQr+Vy&m40nm$d7L9F`oQ-Rj?0IARGZ)q z3_E(GtIx}xp?@2JH5t_ANcqcn^KYgZl=zA&=_|Y9A%yc=C;g3;N1n@ zr_*p$bJC2_7zaiNJ4a)UuXKT#0Nt6#YoV4dnFGfnTXTnp-|XSvlCsB)ymM(()`KA* z1gHm{^?XJTq+>pp=#JYf-v>fn>QNf@C za*8L|0pwtgBf7EdGsp!r=C(r4889c`9*EQTLHik-1-n3d8^eonmiA&z&w#NTsqG@73Wv9nRO`{RpW6J4X$+2;5cux!SD3t+|yG!c9fLdq3_ z=+AV!3qWjgUQT()&xlHw!W~#rO?f^hIpHouGT~j=vQhbJwB_>^TFrdv^7N@_f2D$B>Nz@{*M1LZ+_BSxny(F|W=M=r245T#-`BC(Q(DFe zpVR#F2ss#E2jWEsW*W|$FM}=y9gdMhL)6?(9K7j2>HMk~_=*&TC0oRsLM=Y!%wjX`wzT&ecQ zsz7-sj`gAnRK=YS(#P6`r^%Xk z44;t_C2b#5jq9_1EQ53&h*xt^f|Q<<80bbdnN=?ki*wZFy`$n3+_PF#fxVlp#7QGo z27ViZU+1rAD65C63v=09D8mj*HCgmkASc}*30$l?vHU3 zRTN7LoE;@SE{@HT22Ep(jR_TAvtv{0L z+@Al--0JtB6zFsV6%WT#e{-4FNcm6Mh9lo!*yf*z`g_}Cj{3joQFiGW^!V3b>+$-3 z*CYM^qQ~;f&Y;H|f33%x|6PxFA;RnQR{ooIsl5CQdi)!?{6)LGg{Z%87j>ho9ifU` zE}Kz=L=kQwN#Di$rTZ1C?*HU~EHIaO$c!sgUemR>W!HLJhwmWtgK|I|Mi}=lcUye2 z;|grSWF1aQmj&g~$jB`+JPdZ=|$HBuF{dk=B7mc{)r5JyK22k(Qtap{s)ifU{d zrP8r8H+GboD$Ppm`@N%7vD_5C?_8>iGdPt|^>~myV9K0Q)l0sIi0mj;$!e4AEyeEL zB1yVZZ%?u&xe^=~?U!L!si5X7t&$?_|)a~3N*ky1S<=4h4Ihx5!F z5Hqdi7c5a9*l!Me|VDvOggvpm2(2jM^JB z4vjMw=QKR+6K-8Q2R$xx<`La7dx~{Z2J0@PXy^>HD8+*1l>>8&grhE=TPBvkK z482NqICmRZs<2&$Um&C^IUrV^9hLE4g4mR&d~xkns03~Q34LnjXt{9}5n(D6_}Q9P8&(9vf$c&2suw&0m3-O6@$9mo7K z5eI{hsx6Eo6@|Fkb%%~p47-D!17l{701Vqoz0dej1p}a9cjj%@xwp0}; z+`#!0)g<+ySQFK9?8ufKO!CX%t1)uf=fTw1_;E0=MJc3T1hEmRF)wF9Hxc)&l`SL3 zu0}TBh+Kp1{oN9{Eh!K>evSH2fmt_M1)JUg$;lv&0!&3O$^|hu#*G4%$%Je1JYUNK za!kkQYe8%d=bnQKO-+6hh}GKzqD5H6Yd{=C7*Ayx(lSir#gnHBESttB-b3J~7`366K zsS33(bmRuL!c5qY7#jEO(DIv9p^Zee@S@?Acu{Gx>_@u!d$nk)b^e}y)QFo}`3i+)W zpXig)I$)I*_|*Qz!GuCdori-T zbLXnA4k}f1)jU;A@!@K}wYEjR?3<^)O*n+w(hwo3xlj3m|HkcfP;(Fm7+$muae5I& zX)=1vEg;VJ^t{d>#_@8;#e;X^c<;n%@3PBa{_8*})5=WCkoNOcUA0#F%~yrz{Z+Z% z^zVk#+uhPB4-lRzM>LA|*B^^p_A@#NhZQ>TL{O@nn2(>4(j=`Mm3Lg|EyVDGLiV(i ziEsn~TXORC{G2}x-Q=SHevE|xE(FuM2QdJ1iHCYYLxIPeNX?+eIRE$;PNSR>Q zCxy51AlCXVN$U~s&!kiVh;92eCI+TRlhSf5Y<}hoKeDVG3#OwzReHM{5KUWAoY$2e zzN?2XlV8zsT?h&@X?Ll@F+*%%hNCr)G_|gJ{w( zaAOUWX`FE>1*>REkD(o;T1{b@$3zFt;5q6$*h zQcY6WVyrzAr6@jgj>5Zipaufk8TT^>|9_6Y-~q-0$X z>%K_J9#sDDkqRk)5X12X+4P_))JP3(Gmb-!oxzqz7%#;S;mKnIZebeRtjv}sJpqao zo%4_iv{(c<4#XCqH#jZu2ks-qD<4ur?Ukq_4vE@=l@!0B{O8&B1YB!d+|LBDZL>kO z&47FM4@bWCUXmVF{qP7-xd%tfuX$9}Ye1u31G){wL5!lT&!6~Ne~W6|<|EuQ`yvo8 zC(ARXIT=pV&PkIWPEwm@5_oSpHNYmx@<&ymHW}A1yqu!Wl#EpkC(C4M%|Wa@FFTp+ zd_o0s*-(=~g&=2;3E-aBDX~i&u`2*OVjNC*IZC+e%SIdrVly~hg~fCMF}|Bax z>J5_ih_c|y=ok6cG8GSGji_E$`#0-lICuQk`5UoGIKey7?)x$s@dSF)CK>T4 zrn@#z;DK(vY<(0XiDUE#>q*`+9d%|4wRWoRSjZ8Zfbxk^HG2Q~paiRQQeHxB3VY3S zuA?OTK}7cg&np*1+t3%B% z?cK6*5`0n(%yjoVNQSeLsweSliHYQA1B%vR3__M#Ksj6wdB*emJp9ezsRiY!Nk30~ z6U}pSiU+Yb#X^vl+J)Ke)2CHy6(@mbRUjcAIA^CsD{#PP?b_DXdh5%&@zgE>F>?G# z)o|oyJfpbvd(*>@@;t-v1e;raJDy+2yY)$S^pVP^vC04PQ#jDkV5Leny7IJRPij$* zTBJgbVVVxP$t6#(RL#@5gyxdEA1DqayH~0k$Fs!-f;dqzT?XXY>TD^;L1_otgl9s$ zaqV^7S!alIY*|-H+uhL(n*jqL=grQ77IrPqcP-`^L%i5+riFQ!nsI5Ogwi-jk)95Kocd3)lu-Q8hX`7QmSEa&!Il4nl9_UX!4Ap)mnv<|!q~1HGq{{d202PNI8DwB zzO-ia^xH4jeJN>!OguvTOWl*{&Y@OP=Dm*dW0_L*I!53xt-x14dD=>pm6is47CPzIIdHN?Y@^YA>m=9XV9Z@h_F>=VGOH?Jo>gUv$n z66|jJgIzsQ+}m(_>!%+6UmpG;4?kM-ZjCm%R7sDNH=}<0Q@-A1WLwWYmfm=c9&{YN zmwEV0Yfn}8ZqotvVw*Cg=d#Io(Q|oE&#ey|(sR2Rl0G>mOHNKP<3s!2Qaz$G8X$^G zNw)CIpovmC3Gc#QzD`}7;YS>MU2R-w?K&KUG#V;-vCwQ2n)^N+T{Q|-eE=87p~BFI z7?cA@MAz6QRUfL(2|2ZFU;|t~S4uXh&I1|)5bF%-3Oa9k$S6OC1&{ znYBTU$>6wA4C2Ln&yijmF)|pIO{b?(zamx`y(mD{z9gsavox6(eRK` zx&=omFA&*+6DCxN9@Gm&b?Au6Qu&}+XwAGFFP&~x4Z9Iz{<$Dtl;a3OyAyM&;k4gi z#MQQ+OxOyaD*;5YrBc3C<)^SzrVi_~ZYz!+UZ|wU4e?npe9cyPz!om0wC+}D3Zz_P;3l*=C$I6+T;)4#;#-Pf}6OBGTWh<9KgWBua7g!}}yEi1A? zI_y+qV>nP>CBegSK3T9YE?wT;sk-(jI1ZEpV!LuIV%b-tP)-n>iK)Fk$|KAJjRi4| zGbh71(8rlWG4^%ST^>9GXJ{fvxT&4?o$%U+dwgc=$38f1Q-?f>&HGYY;T0 z&No29X?mvxs3R}NPnDftDSwL_bw(Vbc+swm{s-_L2zimeNdmi6UhcI2lIzWOt_im| zxk}krsvka|g#AzZlMm9Y3VVthq^OE(IkD^@w7&|Q0$BES_(m1fzYS?=NT(CAbCKT_ zn)VGg^VLl8?ZM`4P^L1N6{_5$)|eT$Bb761Q{OwJe6L!sW`~CVpx!W0)LHwn)4M_D z?Z^J`dg*+?et}@b0W}cZ$}qR-0M=FOW$yvCs?nWV3pzJ1I=2a;uiYhUe!^n&ZhW*r zmExHDz=Nu^{yh+6!S^C$=hy|ZJC4*$iybJb)#?%T9p3B1JpZ!HK7>6ddQp2RZh-?o z2g{T3EV1_x_NHe^{?B-1o{MbgR`DRmttQH}pRr9b?@Un;%K>q;p+|D@?Iar@>wm_% z_WO{GLwZ=LfrnK|#(Y4|&l0vz%c{ewICFt6fYMGT6Q$-bW}|W)710x<=!hx`-mjzF z9f5ti35XAC%#GH20CIFpdYY{Z!eJn)%=m?fZ-CGn&ko6W3-O$2xiTZaD4bv7sRUAU z1btynDDVr~lg{?5s%p9zVl-%k=HPQcv>LNoBE?7TXAC*2Rw^Z-;@{M4gS3umfs@pGrQaWFV9Z{`MoZvVXs|&l{!mjhh-89T zFFME%q0WC|kizfj)hAW30keBV>&Qkg0D+B)`BOfuQQ3VKV&zNS9j9PCJMA!yJMw3P zrwp6H!I}YMJ7?fy33-bL8y6=$imYkGd!%Hl8Cbm0xG-@UAhvdWC5IZR2GU&_ub?*^ zQAWsEuH@}fGg~$q#+B+ZDKL$a3}(T0b?UQT=9&10+@rDzLB`{VjdZP@rjeJ+MAVG6 zeFFE?GzoOd%>vPeFX$Fqp~WJ40+P_L=o3s15nB&t<4*e|BHUfU@kcf|b!VeL1sV6q z@wAGvzWE|kHbxsw5?3OUc52vEev391@{4*gM!8GB6g{DkWF; zGqXc;V~uZ>dOlPZZ}f{!c>x(*jSN`f)iNW?2+H6hqb=TTGvZ}eeFL9UN-?^otby1y zTI@yHo?No5MQ+Yer8 z;PXvBqq*FWigz#HYHi#Y+L&kjVW7oJn;Ql4`UJqK`B*0c$Twyq*pqL}2uCy6+1yxz zptz;cPYyRTCWr60;uog11%Jh<%4WMnCwnjXv9B2o(L|EM37>E#WR2gNGng{{tpDw#b z8t2I69gQp02U6Y1$dm5PP-dI6jr15c+IoTkY1s*$|6%z4xlTrJY(xO(`>>%CXB$IJ zwJB86#Rx^Kk3w<9MxmiTmdf)`-sW&n84f-P2cL$6E#Y8mIQT3ad>#(Ag@f(k;ET|V z-Y}8zC69Ee?h%1XQ#5f+qf&6Nz8D#iVn3DmPB{Y@lJK)Q2U1&TLV*=|T#b={WEQ?1U%^qi*&%1aT zbt~L88)j9}QaHpYRWYIRAz_bSGt?N7pkhNwBaMEB936~wCr88YyI*Ov3agmFl2H`f zAyG<8jp1?)I=V^{-%UobWOp~>>o6|aC6{8ztW=|=>^t9Ro0{s1NHe5IV`H#nH9;FM zYm8wn-4&a`>%LyUf-E;TyJl;O~4@HpdUvhT^ROlStv+$`N28dpkcbI48Mm~wow z(H7md*HxH^>Y#|uMw?K}@y2~-xt~R>J;AzOu&h%iCF({Nh z$wFEJ_$9u)A-uJ z52bN)P`{2+G{@K@eQ!4!hPvE?!Qbd?*ke=z*9CN)bEI@G#;$W^1_GlCVsjG1BUq6k zpY$=Z61qY)N_LaLT%%ZZ4<{%NC+OiyaGp-kQzz)f1Rd}@`ObSWL+!c`!+jq~TYzHv zh9wjGY02{qIn>8!nZeG=#T%anS!92fg_9lg&}Wy-HR@uAe$`xKsGNPDu?S~3;DQV0 zqL1}Od?I&YnC2p_#SoqMP$`~o6se2D`d;GFcbJwOt|c$ECFT43P!LW$+-LYxnc)Z> zeMMMFxoLrsV~h-&(H`+e>DrWP!7H`k$pzRuZzLDppOA~a!;=p>%^rImrS{!?jR0dytr)QN{3eu`~UDc3+_&>l!5mfdDwO+yC1DM zM&{jbEDer@BF?kKM-aLMG+HMdj!*e4Z?M<}yXA^-pWU*q#*yUIV zdAE6yaW)$JrEW=0(b#LcB@LA!!(*_1Tx{fIT#fR%5N4<2LzR8RzZ~sevIOhB+Fo;V>rZCfrC%d|)@24^`Y1 z@p*WD9@iaTgTtO~{+Ne9cQ?BVZ?k3Jba0V@9g0N9zM;(|Be^d-4)mu!3U$FK8pZw?%u<% z@$ip%__-dQAGUQDc$J4Qaq}JFP5hFsJ3&hi@AvRA^2Wf#K=2^mZ+9o-OZaYnmxtfx z;Wv8tS3LYv9{$ltzJ1iaU!(Zg#`+NBFJp8#HzFj0A zjA{`HMCE$;`W`;T!z&N}tLLr%A3gk65xhJ(D6vlN`wOxluKjJ$KZd-rl;n$zy zF{tt#Dy4Y3xY{WBDsJ_>==8oU5^?UD!1mTj|1vYU~*o)=gv2y0H2hd(MR&!yEHK zYQ4$@?gB{cc^CGX#$Iq?>om67g{{=s8W(n-#$I$`(>3-I&%Zh5x?Y1Xy9BQU=60k$ z9{yaN=2cgkfW}^PVSHnsl?u7AN*jay|LFpk0dyC*P$zudB{SV4Geyh1>5>_uv46X; z9-ee9$+P`w0bUI}0)~fw@8?M6R(tqm9{zR@Kgq+703USMcA!U~w})@z;p=($cn^R0 zP^7}UJ^YSCHNgmTZ}A9h^zg5E_$NL5A`d^`!(Zv)J01!~YMAa3I8q%M{~r(kzK5^y z@T)xhlOBFS&;tzh@ZCIoYY*@9@Nph~@4?6lZ1(WMe|mstJbbx_zXd$IQYFagx+68V z&xQ5T*rzV6t;Y78!iGfUYH;f*Fe*l42VK|+eB6QsSG%yUHMY%#y(g=lG5o=mI_e8o z)I5zHabeeK>=zeSscYBctjdKo31b877X};youvhTcL^qH?6?d2{Xn>m zCtTP!QvNLJ^DiCsrz>i?#!kAhJ2h70!pbzpC4r;Ta9|OAU(5XHO4n0kXxCHY^tqmd z`5r#S!=Kn6S!{n_Vfw3OGzlYEF@TngDH+)o(j>Utzj&;5U z=C;mfK`j*L5_;Jq^t6YckyOcWmLl|qW`kiW<0~&O< z*C!fl=}P>n#tK~6ld}JL!=E`zN7Z#jjT8S1=x6+lkXr zU0hMs--p#Ga$%ooEYF3l)mS$d_NvA@xv-}-*35-H5XOR0on7D^TJSsW!q#f+ zY+&?LR*2yRTE@ivOv<2q+X9Sa4H@$IB5O*aZaO0;A)=xhY0Pc*IF0qtX(?CzZCF{i zHMeWbv1X8hYc=RL=Sq#a%~`IoKCVKhX)J8cur*6H=C)=(jq!M@(~O1RVoApuyUpp- zf;e|ljNAN zOwc~a=Lik(2zA#P@f4pU(?VnaaA8TFbTwZ`7Iw(P{|KJVd5gRKzwiis;NjPJ_(wea zy&itDhdCIv%0wospUR;NidY@b7r|XFdD_ z9{!e{HNgliM|%W%diWynZ1)u|rQ2(a=gAzCH_+I#E-cBD*Uvkc7yR#Gm(YIzy3O{9 zEfhYv=w$wi#$I%#dqiVAWa!Av(b&r_>?V!zq?;{A{~xEpR~!)7`5JrGg*DaKYc4DS zm|NjLzl`L622YFq%avxU#$E?ze}x5M)T^F^k9zoWo#@}LjIP(%TQ2M}Pr3^{d}bsc zjEac_qN=}$tihKaew~M}0M8n3aw%bXWaem@k6bc0*cj~pu?rlj1vk5}K^m)cVMQAI z#D(Q*>{Az(rm-z9?D+Pu!dr>4{Sij(*5GF@!HpXG+=acWv28AFk;b;Wuv>t+{bH<# zzd-YL`=k7*zB&`0J#;*{ohMOKEwjrdlc2FG7xv?}a1B3nVV`O28yB{ATTRezyWK8u zH3Z$7-|yk4d-!W~#^1W~7@#qp=5s33-jlAGEt7|@Y`cUqb;7+aEJ}*rF!F;tJ`Y!F zpDXHJjqP_~FKFz53tOzQpIq2&8awF1uF_bw3%f9k1)~nRz(OtfvkN=+S)}2<@$j3# zv!l2T^|D81m4|;)r`hXXD9!T-1+|bn<7+%JqqL0M*gZA&r>hbzHO8}*PRpedV@IiR zfk(H7YZHZ~xFfhtWA5g7M`Jv6=*YdOF&;W}u;swqZg;PT4^Hs_mwNba;A!4tE+qpV znR*^RL#H|JN^@jOq#}F6e0Wa{`A2=~5qQVL|I@=i51xv-EhQeAdp!Kj9)9u`U!+!} zA;2S62W8+}hO}=DHVLd_&4%EUU3?OFo&<8@fB#hKt~FXFOhXIs{CPJS_NgmgKGr+vnN#)BRJEe7#a)O(u{;ix1WE&)1@eLX zpa3Wjln*KZ6@of|I)jQp#h_lGexQM%5>1yP91Xe#G!=BKiR1fs;pSfar7vT62G5`I zASe*~TUr-N^*S6{S})7rF-mZfsrnt9((Eav8*ohU_&OX5bH{X$gYOzICR~QJY=RhB zz7D6r?`Wi&WRpjg>;rO-!a%&w1@SP>%{Y|zF3!*|do?azX0GE&@^v^bn7Yo0Z^T#K zqCxhdE`)aHtO>uIpDw}oaOAN2dq#2s8<2WO%fP9zfd*9HK7r*a>Xy@r`X5WlycIbX zgV=Nb$HJ!np9`~eVRY>Ov9KAsu!G&A<0bZeBM0Yl^WTT3qlIu5E|8Lkyx0oigK6tN z!0}SNyl~w=%?6US-e`Wdw^eRM6S1Q?X5@Wi&{$AyK01R1$iRLh#oes8fk}igD-kYq z`+B^^aDfc{(AcB!H(WLt_*B{^9JlTufsHt4eSs|BfZ!Ziy8-VNbl-@W0aC)4c2c_0 zD3QU0`pTM(c=uy9?xj0YXUs%7ZkO#LWt-rguWx|B+)c(Ic<8%EPBjW>5Y6fCYVf>x{CH}6ziC0o^ zZG4g({2Zpe8*)zb+2u&uHp7=O=gjauXNK?f!l6=R!q>^BZO6&Kjk0t*Uhh~R+PfX^ z{=jSFb{Jpm8a2|kc3?j~Dv6FS8qMMV2O#f5X6!udX{e?(|G5;IvexV>qpFO0 zjlMosQ&SD%XG&Iq9{QuE<{1!=X)eLLphj_{`N)9t-De;U$g~&Tg9ex{)m1plJV5fk zHj0h;hTPvsWwqu|%d0ntM~_X&^OUzkRENh*ZITsVqf5<~y{;VW??CrIQ&L)lpJZ|f zxAy1f=&K8$s58d!O)@qnr{Yag{*94mti%xWRBVGr6fOTt(f!{*o0U?y+bC$^9mwwg z%T%*>V`^I|t9E0E86cZ>8)H>VDcob^^%;fcrBYlq@M2Tvf*cGUV>i1SqbQrJ78BWH zbWVH#I2)o>hFmxmZ~jdg7E?E4A;8FvRr(@aZS}C2_zVkiv@y#Hce;{qje>I*0j9&( z!nkh&qRrw#yy)$VA=dz5t(=r!5LYO>zr`W;B@+0~zzg0o=R4H=L0R)1Iv`%X{2tTv z%xE)SPJU*lH>+i`eJ|dYSuUM_ z!1(r9Z4ADt@FU*udR&J7h_%BLvf@X)ldwYe{D`)CQu6mGZ-IELA7ZxzBqc{1P_mI?R^cgLXC(IZ9^dFvQPb9`v+7;p0$|+RFQ(_{8$k<7k)98TjS!apO|8O$MI8OA6bi`ULE@`UE=F7rbAkzLceZV3^rK zV-Lj}heQ7~`lgF=UIK<0uIWCRV?cbrY&Rf&K#m#a1boW1)HKWRRn|(=9Ez{4j)*q%Wpf=f+5QUd zA@a-B&vGK#oTd&_C{G@)MjNk=G0#y)h!;urZ+u1fEVG`S<`?M~Yp%%n6$&_G)YVWV zSBig!t2c-Z)W#>AV0jNfeL2IKc|oux~Hd8ct4ubL&8mm4Px zX_#nUgI8(go*0&7xX+iF=}4W9ztRW|GNdLQ znbeV98D_CMOJ--F3F^xB4Cs?7fjZ_`If~Is7S=KAN`rLVT@E9&b#hcasjg#=Q1xZt zS!mM+vh*x-CB8G*tFAc}FWVK>GYe#QU9-8-$XxQLktK~Y%|Un>rYsZX1!QLyw8A)_ zECVvlCMt(`2kDY!HpfSk#%7rvRO2wj!BZYS3;*rQGS62{!svJ(6lf}Qe5hhGS>=Pe z`OGt48q~vx`!ezjjjCr}s8kDCQy)IrQv40fBluc!njh-5lG%P3x3!$`qrPpVq#?jU zS=Z2EL~v(IMF5T2S^POr;~Xi@ zF$?hS+$08FB+wWi2zxol#2=89${cf*>MApGVdQS|My^?iH|O@}qL#&!>#Tan@Wy5l z-chj{o52=6%~KCR_WTSF$^*f8t>yW6QJhKpc%x7X zCnd*c`+DQ0u&Ei4jc>=NU&4um8vuV-^!fiKzP~sAlxhRKQ6AN}?+{V+sicFvQJ$n1 zc;i{Cff<7VM=qP}=MiphoB_V@%S;>xJ<*R3SW_LcF4FKaHLMK@rDD`!mdR&k5 zn}2{#914Bi!fd7zuRt2EYTw5=%&)jLD=<5%k3%C0Fv{SKeY3S$gbB1J3#w&rT z4U^*Q_dx=x%++mgP%lsqP?S`4jP)h7$6Y=sRx01ctAvR;_ybFcUnF9EG9orThR?VY zt+E7vXjB^x9V0_)3ZbPj$_zik8|}<5g6tW*W`_g&bBXMiToC7iXj{IqM+27XDj=}= zD{(_xJKAwE&8@Ns(*SD%Vjf&{GjG;}vSUo_PDR)lpj{t?Zo#q0^snSHAxkA_s;MB> zdOD~%hz|1i@le$*aARm?doxX8=@aT;78~PCel9CZQahR*jjK*EIsB{;n&=CBG_uXo z#CU7&IP9FPz+WI<*3qoj&dHIgoCo6NsFQ{JSs=G+ep%kp^dXaE+11g^i5Z9ZYb32k z`8(lksr}T<+82Om75wxZ@yAlJe;cuZ`;Pdp!IU)Wx1{vo!-#V~UC;LLw|MwT9-fbN z?(~;{XP2Z?QXf`hkj5MxiFE}w8E*P{Co?n1)q|sat|!B@bYebBI~m4mtgZ|D9gqDi z*o_?kmgJJ*)&XtqR`|}7_#KN6;!ft9@x)KQ6^NRWDzOvb@L;3-kYVUxl<5e};Td$6VIj+eXdPQoX|ug#IyUNRe6Q!c?DukM;uw*`gT zX<;s_yMyY1c+o_;pmRavWkhFlM9g?}j0Ab3Gp5{4a-_4l$rx|S1iEsj_ARUbcz8E+TFMPtI-J4IZe~#o zcjzZdbvH9V;YQqEjYMfu>5KPeu%ewn{{YOPzP?QD4qa{vz0n;@pu}l_S&{DXl761q zEHtgPI?U0Op)dPNbtq9$89sIZlm&KVNbK6Oo@qU+m6=j1)`i2-ido& zEEt*FxpNfceX`Vaj`6EIWqFqvUwx+LcG}yF0dYKKE`BL&9PNu?2Kb@#Jp2juY}}D$ zjW>aYfjATL>J8$DshUd3*jRr;ecZCR-m+#SmN#uin#nTdk@$v4}2 z*766je|L*YZq0f!J5B_S-!s3r&^g`JrSn9GN_&}Wl)72c`j{m#e6&xLv3<;~#x172 z-8D8_5(mbn%kjQgYtQU!zOAN*iu;-P(-kuWQ<6XQL4OlpRvA3cOq44NqFdr~m-7mu z%jC6zSZ&_QJh8MJ2-lh<)ji|za6ibrRW=WRZ)bPG*9N}708yKy<^n8AZwpI*Fxb2k zUuzp!VlGvOWN!&pria9TAs#Fag{EF;_Ar3>97F=vz8ulIksB~v+xc>AAi%3H1Q}8@c1qTg1u%3JV4t`ia$_z0>5Te=kqy;g@yw+Q zc&5N0J;uzBX>c5x%Gxoe&pzD2p&&)4a4g^`Zs?ROn{n)i40CmuhtSc1LqZm^Mo?Sw z>zLErnmhkD}l34w2@=C2Q=mscsqE; zv;7>I@xa`xm5abT@l>cgc(-%30PlD>_w2Ll;4O@v?d95{> zHN_erkiy}a>d<}el%%W730C&m>9YFX_++{JDzj?>CnL7^Fsb|mUkEz-3HCS+UuE`? z&G^!J?&Ui6QXO(ap!8@blzIJQ0?n=k+a1&v#Eav8F^EfuSx}ONJd+gOW`Auwo@{Oh z$ePpAFM}|bPKghMx7qJN9IbRJZh1wLKVvpv8n_k?l}x~lnsMi8;@FkXYsBe>nsR-> zpV1>rGp{x!`)&=hQXhdh46~Uzea|ta$9OEsH(zZg*S`mX%;#Q&9Ia|qkRw-P-(fD` z4uCs?I6gE6QG6b7HvcK{<(=_YM;jnZ`$6$O#3x0>7nWe!Ied+IMaF!@MXHQ1ZuiSr z065Y%p-HA>lmn)X5!l+_FQt=BU&aIA=})H=Sb7tthbJbR^)ePBF0z14lkt>l0glu; zFiEen79lF40mS}kWbn0Sa*M@?b1Sd}JWU{{WjFg;)2jcV7N-KV_CuOalA3Ex-(?SL z7J(hT6gO;3x_K`U8;TCiq>p%H9|g~nm+3TY&{OqaKE(`VEJsvi9V@4pvojylDI%L> zLYZ06|8X4^QGH~b1EL}v7^xInpGrLe`3S=UqgRZTHNgbG94*6wuJ07HuDyDF>NItV zt~2vTKMgoS6{P1=G+_H#ayCL6f5sbc)r`a!rLMz{;ImS59ahE9K_b$< zYaYhq{($Sv3o}aleJUL&e^X3rk|c^lz7!WO1uU^Y7s&hX~vQp%@G;@JT3b`bNnf` z)zx@RvNieoMzc%CzjSG*T(;mJX7NR@19tbXH?$ZR<8(ZyH@xYQ`!{&%^cKR%y1jvH zTdehnzpcgJK^QqWta&LuPx{_u_Re_sw5&L&)Mt~iq;-gnZ1qY+H_Ad(FD>%kX(CmV zkb8FL*m}})npy8^P9Ki&`w)(>CgPfa_&7pm1n#PQ=!5S4YBaw9ZwH~A*;ti(qM*%LX|)K&!dGz!N8HpKs^ zPVkgINJKL@g@5cRd^7mJQ?}A0{|R_1`zgY|Ru+*-QhJLSs80h>ehZ*T@7Z}4)&;NK zV%7_8MO?((2YK$|@mYZtrhRSOB4pDszt4~+!ta66P^>47#dN(v?zAkw7szS1@VSX7 ziCG(;5&Rq(vQ?Z>cbn!N!)@0*Go}JxfRE@&z^DM-lPyTOULdxb<1lyP-t7rr>O2wD zv4{E{xZ{F@wU3c$)6L@gY5L)Z`LM!HrBbAFy6L-$MX~*;(pPpqo0DJau^iZYS|({hb7;m7fFs;ZrUuRY zbAR;0s3t8(2Vj-6K(z8c$VCny9Bc4-N&F;tGKiB6`z39b8EA0;a_(;a6L_XS=q*Rm zj$tyMGRth3QH?mxbG7CTEuDp5>9EUCeg`V_GomA$Ue?}$$@Q=|N92$%%WuW1-x`Me}6(Z1d90qljbwj;!h4*=X!zIx2F-kbfr@nZF?_Vob*$ z95p9o{C-+NJMY9VB*y_qHbmeqvn=BT;K;ULei!oo<1~0D;30o{VJJ;!X0x%caa!mF zVuepaHo{MUv5BKW9BkM*YE0{si?Zx*0!Kyj*8T-uN%`GoK|2GI5f(uLyRYiRCgLMi zx0g7HbIgtz(TIyET(B}KXvf{TzsoY#nmKx{ zM2JMT*ZO;4>ZH?P^Io$gBN=d{zl^=twD`;Vz4kBb{<+vjP7?%qji_L{R$vtF=}WW> z@eEregSU0uBGPZJIZ3jvHk-+%^UN`LNGo4p`ZIixi8Ng8lS@5BMHo-cx(|wS)`^7e zA1xc48TOwUZg^(6(HUX?cy?zTYIy5;AX0355z}Bo8Vk0$sV*#2v|FlHM7MS@N%}O{)e)pS6D)(iG_Xafvv753!k#(B-fSDI#i%Hty z7@z%T#)>8MfSKQ@6*6^}fX;l}8W@MorTA#7*(;$t9paplDBE7PE;RFEI{$mkd? z*X_XpN}9t_uahpMc4U_t%j92s^DQ#Rb~+oe5sibC99O6!t;4R;*()P!7Ma6aoa2Qd z%JGj$d5r*3^K+$eG0tHOmJy51*%>2$iQKchL8=#CD@zK!A|i^sa#^N3bF_q?m0kvK&`RedKosT_&v<8Kr|xVf_~c{1WoPHhWBg) z#&P{Zo*{?o0uXIB7CU54JVXAt&`QVABFMj4?ba#GS%7nAfxMCvMI4#w

MrX^* z58-FAS*S-{NqQK+56lV`KWxrW_#-G)g)zR+mZeD2fblFP7esgH4WbL^OhOGFHLqim zdCTDJ6i$+gW#%NEZ{Bij?9YhZ z0B?)+n7P!B&9Hy@kpYjJDF`=9#i)1&$cqy~1pAiXVRJwotk} zX*NH_=gHhB%|)<6;3;!nLJ`cwiqw~ir_5ej>cms#)(kd4OAwEGod+5$RZpXwxtHPh zqhTEq(qlN~NhS}-5CQ}U5Fi3#gn;1<66LKRL6L`|gjH7*ltEEZQKCjYt|(D( z7ZjH$sH39bqJj#7Z(LD8*%gJAxUwrQD7oKP)0K3FuRXyI#pd= zT}``l6VlE)Na#XLg~*E})OkIL)IJuMCs`w6@kQe`z9;?EL>dTkrFJu(b02vbFTpf_ z%6EQr!tGD_*0^vLpX086)YCrfZoCm6j9m6NJU?o)7EhR3O7$8Dx=dnH{e!`mzB^k& zpI|}gu4Pt&@aLfWu?OZ!*=;e|?Z}oW{!Vw@Pb#{`2CBZ9l`Jc3V2ClYy9Uq3x=P`* zzWhY?OjGOYv9yStj%Q2gSzk7G%q>T7=0EYIf(=I^mb4df4vQwf198KI>8~PQweX>g zMB@;k!e(WX^qj9G@da2>OQd%P+%J=!^Hp~3>-1>8p2#0-F#}oR5#|zsAFm_$hxX$` zlwJE-34Pfr^ql>WpANXh3Hv+Y0EBMEQws7U?YS~N3>yaBX#prsFw$ARyG z4cGxUSSDG}6qmJb2QalCfm#}k0bO6ik*C3*cN+Yt)8NY* z@N~}&1)OgZq~>K`Ad@ZTP99yKysxR`vGvJGuQZW+e0_3BQ^^zSlPi$ynGrtt3K~dv zJ?bS__HD!l0i&+}?@_cv{%gM3jX4G~IoTcnV3}-#Mg;~^PDz%duVL-!A|t%hn#Lw4 zod!SoH28~8gP(F5e0c;P(w$4I2_myIOg&A8OHPBo^fdTsr@>#=2p?!Lq3P~~aKUC@ zk`HZJyv4WJi*WOszI?A|rX1YrEA!5>n+7Zjl#mFX8|gdYz)J&6Zk(kv-|8{2_@l$y8E-*V*e+rANz7}gB7V?V++pecv>Pxb8#WVwwMeFV%^cedz1$H#e7k<)aULGf&6sL(Fgb;*+6nUQ06F1(!PV zu@Nk({s=qZXG_V)xb4i5X&=Ku*2ii-#)#He0-wPBYHH+U4`6$M_7mR{q#pjnm)*ti z=g`w1z@M3fpPIAiQ{NusOxg{9aJl5~Zj${qyU~Ds<&CCOlRoo>nvkjbGoK(+@4xzj z|3{g?Fd&co)i)K{PyE$a(gbr&a_Q&3ZXl`p{PZNpKlk;&z-#O#_)nkw0QVTQcq&)7vI3EPRWi@Q1|`84TxDjkp? z_xkR3SS{Y?+YaVs`|Fv{+mDg;b=kEaBMyBCRn-RIwyIRAi%?DY3i~-CB`^L83n$nI z|CO)E!5sYxGk@^@x}Iji*BZ0C0pmNMG35v9X_g-FZA-ZV1=FP2K zZ&)NVb1R{tHF{s+tMzvEH=S5o|qFQkWfs*Fsy$$&r2NIv?;x74#($`ATVT5)q2r7}hF z2A8vWQZAN_2YnUZIhO37=x;Am{!Rb-ExhIoS@kVuLg>HW;Z}%RkCVdhAVFU#Z@`2i zn3@L6t_Y^C0TVogMq+i7r0x)2kj*F^t>KEdKdy?SStVCchJ+(&~S`rZA$@0sf`@ARMh&a^+c0sDura1OYjFcoB9cZ zL5FL8fQQmTr;G1L+$a1fg+Ju67~Rk^5@o{AzOtT7;$6LdN7)JA zM#!ZI-k?&gyg_Y5Cl&vS&#(WiHM4Ut=d#ca3H-;m_P-eDp8sGB-VrW5j?qCaM&Vv5 zS%4iGGfw#W>o{ImT95DbZaLu_>YZyzx1*|!UReH}l$@c0aZsGT*SOk}c=mwG#HZr##tiHg61I4uKhC>>Aw5?eeQMX=^qnOo;e zPkAf~|A17S^ac9d8HHYiIAx_xxXb;06y24w8QEKK52G;%R-yN=GPR$|@^1e{tU6!& zL1&^mI{-{$^%>5?eLF=q@v{(j7gZP)&zFiiY=mkRg-+Ax7V%MN-!C%vq%ZyK|6oDT z&Gny%)9|A!_DvMsmnR-fw$l4?8=*V-vs;S*1{N0Cf+ z;-={#ShH>qhOJ=F*SY=*2x67>TEGJUZt49OARVi&X8~w51f#*$67R8khm=c3lXMh| zv+e~IehA4O{~#*lYn^yEC%hgZ*P0pU zkDhJ>fZp+1$i@3ioVc*)3_CqMT3H!(WcPcxBHk+YB>vu^_;Do2Wb;4_DPNCMbLG(9 zxHvgK;J0OTqV*=04?-Ve6}U%pYoK1|EszDxtx|oNE^joq^7UmvYMWbJ`WcdBVZB-w zBv~WUI7Ns7^IQPcqu(RoqH2QL zHB#qDmhv;KLML<88P*77-gkyIMq@fk?^LVczwx<0)tcpGu1mG}UGtJOYk7SR`nHCW zYtyVDcu9S8vK0uuij-)ey`2l-aA(qPa;_27&t7;tN}FUuaIjba;DW+xz=Z(XCWldW zRI>_Rit9E2`Y=corD1ETNbypwxd1ES~&)s8m??*;ms2~y$Qm`kn~Y&Yo5-N zDrLD=IWTzeQlc>}o>jGIS-PBTg?G<)=2?$MO34c^YimvP zB66_3)f+)D-ztkR3ty9O<$EIB!qpv6l)latUni^3dp+)9a86Qqcqc2_BX@mgwG3x< zwl4GG*pyJA)w>nd#irowioS_I-U`u$Y7)HiQfRewBuwgNeT19`x;cHIxfFM|_5c&; zVU2KT&}9O$u!l7g=5|N??d8k97Qv`RLYC2K+g}6*;pa_8+#EM zFeC#OMm%w(V^(})IM1KmDg&1+pD1<~{wO-1q~uD)hq2jJTSlg)(jmL;zcb>JbBDiW z)yi<+xEX>r$_q5K3 zO|I@~El%N_n~G&-7M>>iW?R7r`Ek!nds)xot^PB5TcX>fgVgl4DxJ&Hv#fbY+<2BH zU^S*sJxy&NE9}s$JsW2!ELcQMguq5=9MmSa}L8?FV2mCkSl4^{pN*WH^ z*rF2jE5od$EhWWPVb!t~33^9cZn zd;t(-UV|_iXztNC3aDof4kLC8_C@~4xD>!RWYBa^fR4ftnAT7+xva!GH?#=pteBzC ziJ~`?rzxP>4q)TZYPH8fCdx>@Y@pEq@-bZ_57)T><{1ItFDmV9oyba1K=wOcQ%JV9 zxn}n`6MzYR9hquc39YaK`Uz`v5@j9?FlEu0C*i|Phl2MzG!2WwMX)x75mzv%kWz1g~_l z5^^|}@W*us{23gJBo3@}D~`d1sVQ3m zv}T!!1yUG8Scq%N9WBT(2WMK70vQ3A-z@<1y6Ft>1|g)wFsnU2;%+5eOsV)YM4TuZ z#ZlojDYgx3XKFhI*E;~z8Z~kmfCbXr44*EzZX*T5EWBRwckJI8HO#qXYa<(nSz|gH zr(k%p0tRPzXo01=S8TwuAY3*acN-y+vwkF}MN?Fx2Z|Dnr*3Wq@Mi&7Jz75b(A3;% zv?->sD$|^hWl)^90MHlfR%9V0qV9}9tUKjrNGHx&3LPGWr4T9Djfk_$^idgkh%+DI zOaK-+^jOKkk2uqKdizC6!L^Ny&K$(LAJ7Z_&D zXq0X&(CaXv@W%QmP&A##p`-SPNzHej$O?e5BWBlGq;ixqC+;G7Wma+GB46Yb*Y=>W zrJxfw&)rpKU0Ky{UTm7tAg9879FPu(mCzroKp!fEEya)u8v_cc8gOIF0dvz6Wz@hSOGjV+?>YJ4qS&lf(||T@LnZ-0L*pckM5}E2Qe}ip zr(#>PK^6n}BdtkesdQen5dtM)ohV=ifOKx@s1s9}C$QGf${2cHvmA#I<#>cIz>qnw+H$DY@{P%|K`Mg2Y^8<#jPG zfjy2{C@a;&70CtepZoV z7|X{2kCUum3WX$ZDv;G_FQG|Reo87XX91|7VE~WRzNWG-rk*Gf1@8mkbb*XX!XIZP z9Nv8Zjv~%bUvHai(Vl>tU=eTDaLLBqmW)kf7rygl)fG{q{#;kaX_SVd{HG`GU;K~}F+z8V+Au{j&3 zIIGkJa$pM9Zxf`T+{*KmOIf*Nw(Gu6t`i+i*z*2>g_WaM;Q4or0x zFAF5^60B+_QTXgkibjGR02XE9Z_CQVuqla?HAmW)vOv4;p$;@fc=pb1-&Dy3%2h&wR zr|qSwZbW0DO|mD@ri|mslzm&^?%A_xifoiDDeH+5Zp8~KLH=}^^^zX&nZRD-k@B6` zt-HJ`w4kX(x4bU4fTncky0__$;BUH!~07>Y*8RyR!aGuQ0iOCPg&A=Up zGmK`>#5lf4if5vt+rtxPT7^zZcMty$zr;T&h3JTE+AjurBN-S!G=SBzc=XLIKQXn9(6 zshMZh=$u_-+V$2_7J9wIAkqP4Z;>4v?s0?la76q9yi;n;)L9Coc!9OqxvX1YRYxwv zt8PTib$M)emPh-HlvnVu6%7A$ll4r5TfD3eS=`0sTjZ>tC&`dS&T?}Hkww-j%`{y~ zZf^X{=&qZsJ0R^Dx74p-?z$!Fc@+9heFMcy{9;E(aZ<3@tXzkuEw-w?(2?(UYlyE2 z%}%=0%Fg8+CC{k}4Wu)`%{(tGcVcN3YzmiJ1+k}5bw!natU&!j@THrq?C_iitTnzy znxbLVYwDn`J07L|!TKo0yad30N%QqfAe|?vV*Y6_GI@soR<*5ZU3P))@Rc1 z3#=C7lti2vz8H>Y%hT3b>6_qjlTi|1`y-6U^$}kn{;GW!9H(_xVhyr36b4GYKn13d>i zcsern6v{)G1<->g!a)Gui4ad*nv_3hRry&gbvs*5JcmbAEoAL_t4L3v=w@k5xd3LM z`(@lPO~rM8Kr`8O52kBvHdviy{Tf)qk@-;SoDEigsI_K;Rgyx7N)GW(m?d=^tlr+m zdZ8Q}=$^My@vi8uXJIz$Ci)Y?D~WI(u5En55^s-RW$cUAV6=N>m)Jmf{fpKQeAu<> zW#{p0e0cZER+7hi`w4k=aa@*oH(Jkl&qrjV^`rMzy%DN?_}y2nH6HyWnCfP&s79(q zcb72w(>C9Er?_x5u~8|ThqOME2N!v`CNDNocL0ByAJf9sTdXj9^@KOA%1GI!NvVrc zLmRGp3s0f(WM#;9tH7_HDk74Q8-(0dkv#PZNqdl?AX#lN3+4Y%K0p*qa6>}#jXUXR<&_&XFkK@wg zW#1lWq)C+%d-PD4|Aq7Hv4w=bfE=@B;}=lM>!KeFpZvnvy5PLIHswoeAV^kyX&rOi zg{yBw4)Q8A6)N+Wi=HW=s6nFxpWYVD;yIWlhvmsx-*Y z`tn!b!q6$sPo0Z*1b2RgXOPr!E7|iEhIEHVujj#I@YmME|3@Cd1J1sSY#DI?%arD= zvHmhD%ZhDBUr#e9n8&6lyBWSrUH{k=n^Z^o0$u0{2yU{|zCR|_Ut|hxIS7EWBRDX7)mz?}Sa$ zInw^fo?WoH?5n};8KeA_0^;=Mm{3PtHU(62Q+S~DJ(^~LYxtX;#Nwi# znXu=10rW%tBO^_u`^RFdyB`mluYvi!5Bu5srkxsISZfV*jnlIIpVoG*L-*W`cA@ns zH9uP0yi2WzhTxH9zvCE;Bd?aqp`&o%^Q88;H6nc7zpMmrqI(p_+~FrHKa(i@>AQSN zZ}c}Wyz3{c$R$NM{y*r;F5WmU{DK83yEC#()|X{%3I+5g9q zlTKPyzIHU4_K=7@k?q2pdS1^0=!zq~wQTdKh?mTl30`&7F~BmPDvZd1y%gcFPnA*f z7^NZ`H1wXMX~S3oy*RnDMOlCTdH_rbY%xk<1I&$?2iI&KzHacTl8SzZ7al@qVpI#LXY=YE%64mAaGIOCGln zcS8%~)qaQLv;FG0=5U0F>cxLum4MnlSQ{l5(YHIZp2z6;MNAQxZ_U-7neJ{lkZu zYKBViU_bhaOjW2Er-ci%)Ha_q7rY5PY6Qm3Wm(Yt-l2HScEygk7V=9g6^Cyh)Kp;( zFub)&m0mfjE!1E5C|c>z`F8RkR&pS~ICUD%X25|^u5L(kX=7m#yv)mU6hu8O>~NY~m%s$cR2+OhvoJkvlNx7g3< z;&|iDzL_pV+Ne->Uh>DTIv>EUngK9mxYQ29u<9ts+NfzLSMLD3I!{GbwL8kvJg48J z^IKy0G)ee$EPZ8B*9m70N~Xp}f&SD>acVXzG$76%U{XuIPYaj(T9dsW$%TRtf+f z+1x?()-yFdKLpCEsyT+;SRK`wI+w8pR>E-3mVF<^2NEffLE&(cj%f9*9ph4E6P|lE z$_pLT6J|>-2(`X)B&n0*1TtiCC$&e*VSM#8N$R5VQfR}pTT>9;gfDO$PKN9&aBMQd zRp-|p6B#a(&>7eqI;FFU>>JINiq6K*NM&agSv1L(m@bW7?aQ7(cuE&F(u?m0Rg`0e zXG@`KiN?W^3%#}2T_n4k+K@w)a;D6dWd(ZzDse$UGd=PHzP={whT&!?uDe>K=eUNN zswDNjQr%rG#STh^6CHb~YrXelC*lxa8`;}KP1SXw57(A0Nj+4yw+ar9A2wWAq;B*) zpkM2du1i#GxXqcWvjus}&QiNP4~Bz%6h3$}T$Y@z#_0ELEZKLq%JV+txqb4Vj#Pp=l;E1bUVw+A;(v&WKN1yR9u%+JqnJt1{@?H}q4> zQyv2mS8MCLv6PpnA^M>RymcZNk={s4qKP0T0e>4L++PK!NE1BEK}M6Rb}66oQ6An}8J3jk zPN#gMTrDSd&r|7-Tk`ss-mFf{ml2iknyKfOwO}cK=K0 z`37U8=OROnFbv6vg21Ml4R)kA2Fs3cj)UupYtjz^7%lwhyw6|?LsGMLFW}T}gr-6a zC8rQ;az{#4tlp4DHfIAEQmG940}LD1=WMV+P_LsL6h(y_oh2Zi;EMlz8H~_ zaNm` zOPz2yLKe*#((5>Q$(WLxj_EA^3ZygdQ~+^oX`JOG-w#r`<3=LF#0#8osuRvcXoO*J zUK4IGt8$0tGK8j(EEGb0a&F&@r_%Rr=7?pq#RW)~M9~?Jb3&HH_-p{Vv9#8*Yp}{o z48GJ*Xltnh%6sHTX*)!<$?T6LQX1Krle%3c(}t+LoMA|&4vodL&U1f^xWttamnfTt zsLuZDoFWpW;&#k{rh<;FsMk0N3{`n*FDRx}?fWd?t^KD=9ID#mgyhgr6--?Ba$Oy# zot$_(CbVv-%E%2OO0h0-!W$5hCp9zupZHpg)XeZ?k2`_v6w&BsvO~sN-19@E$u4zp z6n~6^GxVHFnp(F-8ciTUlJA=y8+*yVwy3wTX1cv@5S{t@J3Ky-N_Dpp$j({ zINc$DBQFDwMreBJ&iLIwA_d*(%J>d&Mh$J9j2)b?XH_r|2;Jnw7CGUqPI$W$nm+L- z#Eps)a9xbo8^*t1SN9$u_(5IWs1F-PhmKC(#ZI^iAyq~d_JBlGF{{vtTg{CwTOxr| zyj7qoLCBvG-DD_`ednoQ)>0%f|I+}YO8TC<4<%!i8r9Rt%zkX>7(NGJar8Nd4n?|- z@jqQ;`6w0a!X81=X8>;2=YAY%C6b#_sZdHrsr=mN(w+qgONj@hd)PdNBBPWTK$ z3hx6zW6iqksjHj1x2|qEfaMcMS-UwQjg;|oosgZ8@mHMiHH2&pTIPL_ooRnC4wPNO zXo}3gMIi_@gXK>6M}%ZRfxiEHgn_BFDU99H(5!c8m}Yp>Y-0CCyn1Ac5{!IH+DK|L z-|u9`2eZbiK#0mQJlJjD0uKbbEb{E^kQ<9J%3O;yvfe}*0BM>3wf&9r*ZwWy0&3mDJop##BXuJJEU$DB>Lt8l`Q?ns*FokItixp zJ>|q}oREEm1#ED_bx!z_6B@hR;ly`3;rmW_z7&s%FTwYlYheKL$e8#JDaV|o<4#y7 zCF4{e*G8+dq*y16al&{fOq8Or@x60s8~jn9Zv*-Oo`f-sML0j;`Y`<;flL6By?#Al zR^;m|`or{pLK>ZJLmEF!pRyWg+Cu}{H$g>?4zi?p0v1ELAHy$8Ca8nm^(Bbg0LBAo zI5dcX01i28z>I#ffm!uL6-;^RlrnZrR0SzdpMox*?F;s}84SprjG%}5U5T7iaOq<$ zvUNbnf*F6tl10OO>3&)u^97`41s2BFb+?jJnEq#n9s&GgO;poz+RXm#rSuq6&?>X zAAzgA0c@E*-px);<6RV6gDt~rDz6mFj#hSeqWK#HU?Z)E#ElvWxO@N$r6l+oK&}d0 zND}r${z?I70;odT*FXT%4a*HkpaZFIcU-pxkfp9F!tMY{X6r-8$sr4%u;F6>0oiboFaKiRyif=VMHbBZ0WBmGqi^NrInUIsEzNE$;47fU!;^0GYiGX8+B&jUr7R z3g%WIg&PPkidML$q8k)B1gm`igT&O5DTIP;L7v9S*9`5a2Fu8}J+z={YEE5rFMS6>SH9r~N{@0m6BbCpS?y?bybB(U#zWAw1=s)@Ryu$cC~Y<-Vx8j=AtV0C%($fO zVAPZ#Kx<~~dOHwl_j$ve*k}3vTL%+*2kApzb)n1 zWL1iN1jQGtg7&O3HOUqrAN~dcST$qw2Tsc4)i_DI{Wk2IU4OAUA2M>&t7J`4-Eci( ziYjjRA>^frOabfwj03Rl{277sWbG8(nt$Yw)}ujU)HMXx^phsdio8VKyj;ynn}K{8 zNHgw@H26AhIi90`9Ih=_$MDoIeDD%=II<(llF(!r>5LoOQ`|*`!)k)^r{Afe`U}>yb$Vr59%t)RCGS)8&P3Q& zxHnF&@yVsX*H4;5zgLrVHO9)m-#a_%66M72)dY>jnWKF%k-hplHT1u97v_{h*QxW< zXv=g@Y)dLTV%uf&uspt?P9FaRCUn<4m7I75dNtGa&Jd|QicKAx=Ba<7G7u_f&4Mfxga#U`2?)C0)8`vzxwM54sZSB0k$XT*F}9<|3TJYQ{V z_XW!O-|V;JmkufGKr!+h5vlYtK)wCS;RR~(Y0P%hUnHx!$%^+gVr*(AZCc6J(--5GE$U=rYRz=Qa}RU94~g)m3I;%02td3O}{ z@x(nGm#lXx;k4tMp|Z1)tmtw3%jQwIW$1KcTyn?gq21lj^rm>wQ^NidydG`7a}>4; zk#S%5goc?00yw^r*o<+eny9hH4?xIkmjDzxR-RrI5jr`A`fLl}k1XS)d@*F-y9ly# zl*p~BeJ5Mj3NM__v;%!;@#IOH=?Y++nq|C`6KCTvPKW0KG|5KntsO+|R21D4cw^9L?tjhTgpdINy0VgY2uS~8tQG?h+e4o4Zz zw4vEV#5u?f15g{}Ma@XpRWTVo3vflwduaWN92x^TZO3+Dqf#TR60ccp-M|ix z0Oa;IuJJq&P(V!rkLsBdC9&WC&;oxlYJyYJedR zq&4X}#D}jiX_+m>cd3H3gHE;BT^gztTB@@9wL(Vz%q`?mT$5Q-@YyM8a{gIXCpmeS z>X7*#B>Dg}m;iu3mWAWemqLVZPb)&o7ocK?r6lb8B1_-FktvTmDC(H#mjL`3Nw?zq zba0z1jVdA?*^?KA;VKvY+Y?bZrF z5B5FyGWQWiE+3hGU zN!?)dO!mBYYbKNSSov5ajY;s+i_29RQpxUFN!`QyvfC$iN>P z*M00|GU5XP$r2iG1v)OkCE3^j{#Zlm{wQ=$KhEsB#|gi{S#`W5LFQMggp_|Fy;1iP zsZ_<%?|OWplb`9V-#l(^l+M8UK{@!B%Ul@%AAo|=Kv;Q}mdk4?J8A{|9Q#PxU$S>$ z^!mI~O|HMi7=N$okBPP1iyKhvRK6E|brIN+6FIPYlpA+H_hCOi&SJe!mFqhNDu)y_ zUQK~qiL&`V71TEtqvgPTDnI4ls9U2BCHhm|o9@C!t+Ve}$tgd9fUN43Qx*I=sK4UG zFPpJNj2e$cQ%d#ystDg^N_rGqb30Y3WW_8#DR~%{-LD!e**Ju=9V^ZTr>sWH?pfOa z;4$}DhxMq-a7kH6Miu5c*OcvSSx}|2yYsRsCqg$(Cqd^zS8lX2Pu{44bno`^C%Bri zY&ZPEMa$w7Jk6y1Au-gm@_B6VKRH*$=6b-ZUc1h9AB1L-5_uJDx|xR1 z2r)UOEJdaZi42()A6&lJ+g0R+;24nT0C2pZGe6#FpD$e@GK|JKFH!4^qVa2 zei)mOG7vaZBl?Hj|Fg0~|5s%XMlqC&(^;y+sEyYYht)S~qnfBT;#e=!52<2`4Yhe; zuG<6HG`MUV-gWq}0gX6Zq1vC(Bvt%zjLjz%fsHOfBic{yZ84 zR1HnXsEf5Bjs@4_!bvOC8y-~WqiR)j-Y>|?{g16MC4@D~rRQQ19z^AQC0G67LqUSrcX6N>!C|62!E? zdVW=v7iZtsH5Rw1dQl66 zl=Q~nQV>#&EXa$3*g2vLqU5mvO7BC&v`R#E+rP!i^pwq5Cb@cvH^Vc%YL_SbLb7nX zOtQD4vjWFyBH4Eauyy#m?c0WJ|A(Dbd@c-Wp0fFmDm(NikdT~qVzRQzU%IkxLsq&c z)|kIPI&ni!TmW0B-0{It@hhX^_aiZ^8_YrqjX1$Y68BCr>fRnE8dD_Z~ zKdICi^AJsNv6$&(aTmj{XSmt+a%h;Z1%Rz?^uy{*K(!Fmi}lm5(t5SZ@gDe9`ma{$ zoj%1oCluQ)*1N#P1LrPx8 z2GCTDN-lTGGVzO?a!h;#;-(&Md3poSIP1sRIOyYaf5|{X3mjM+8|WL$OQgj|(seWa zjAyoPUA-C=zYB5FCrWKRPCEPaCOnz=dJT>{djva<*JCsDCIF3;jMIJC1i_-0^P_2Os&}Qz|X=E+TH}A9RRWklSfY0G_oVzKs*M zcS6%j+Gv6MGb+Su(sE#8NJqtxgB!!#NEq3jM?^O#ff`_ZD1eN~hyqT>)^h~f$uK<+ zKrPVxvLZFog&56voQkkX>AaXH)d}fc81K|frk)dT%bf4A)Vc0`PpqC7Gi5k{oT#@O z@W{}uzZr16@#z=j&-5O z=y$ZPZYH2R_Wv8p7zRAqGkzD?8PlbHZa|z8F`e<5h`SqgG~yJ8jbV871&&1U}Z8iyUGU4x;pCgRPh_2i)uXN#iyYQ2McMEoQqj*{5o7R-n6sT+G z(n1%cv9JprrqtLscyGk5?43?LQOY;_ib5q$mQp7RNqa_R$wr)PnZ}UHWLOMfomkAP z5QFJ#J9a@g-2lW%M?Z9(L+2P?i~7bkjgCWvEGxgNYcISD{5{U3$G?oK+tXXi*7rTh z!v;C5r#m700gD>qgd?4hOE<(*6AUkQ!pTlJR|@{^4-UE&(SCro0RFi8b18r~UpB<$ zy~88aGJfpuY{eMh8%->vX0KYB5({+WdFHNlDlg;*n)-6j4%ops{IN5~Aw51Sot}d_ zO#`r9SZe%l@JVQzPh=|z3rcL7Ko`XH=D(4i^c(5PO{UA4WieS2_pBP&J*7#422Hex zPRHk%vFOKU$c21)04m}P#A!Tkg|hjmP&1Pq=%h1mCay_OMKX`Ukyk3xo0__j4+n7= zt@M0ObsEqBkPQOpb^HL{_|#}j$BUK40e znVUdoH;r!DG`dyO=$xj}!BfziJ7YiY{TuKUytQoJfNh|>GZ-YtHmFkPvgCO@l%Dp<)T01IaSUJI9Y;ke8q)_yntm1&vQ~U2a8(^aa4dB2h}W; zr7xOF?7A2acCvQiUHADfsnpYab9U8B zIPrk;1mxgLxNE~UiKc3pT;t)^Q~vC}|5tXVMw(r? z;uST?lWR0XTq%G&-P%ctXnEATc$~HK6COe_9y5uYSMlsoD_v&3ir3$C4jh50%JoTB z0Wisv?AKIKru;Rot*qPPYb_VOhWon}H{jgFr(eK2`?^=Kpy~r5e=M026jjx23VP1f z29jO`1f4inam;m5GihnT8x8*mua*0xJct(AItkB67xweS_F+@8lAOMc2e2tw#6SSk zSOjsVqV;A|wXa`5u6{8l!#@qlRIyKL`{O%DSHFg%EJ$X_>em!cs>$AjMx8DDHlf-~ zh?AJjYPWoTGb(myv+9t-WpJ+4k<-0^CnfK7oL9hZGE^qKu8RE>g_h};&DB<*JB@D^ z;06GPT}~iDtn1C@V9sF(TLaL+FwNG6ubbrf>ng)xz4>!2RZdxncIx#P)jF32u%Lke z`bVP|Q~v={@fY=x(qvMyMFsR0jp3lo12j<0-hy@FD5?>sP;JdM&!f0#<^nPX>MbL!^-q+pU?0x&dxb?#tI{4(cm&7J2E z=q=p6aC+&+_XqAm00#rA8fjVe1^vhbF!Qlcg6z2=20JqLd6P3asbB{FIH^bg&>q{! zu{YG1hEow`%$w>OZ=RC=_r;{+JSG(zwWUQn(&lgCNp#LzIAMmXbgblHDSJy@)3Ghu zl&lG?ACt_NE)6NCMmQ~x-x2QmSM2hhvmB?x(CMMOh7$8i^ZrQ`z~D-&@=vp>Kdt-iAB1GQMuuQijBY%D)t{h>Mw=(Qgr zd%hGNg*X23L-l4RKT1ty)846k4ji1;`Smx6a%N%6K9?Z%$D@|W(T`MNE6yuv+YnPb z5jt#kFm}@%DgIbhu%M5zHrZG9eT>I2eZ$$Gs4<={6p#~6dM5U7_Q=ivmQQE_17}x> zFk1d8vYsouKUIZ^l#E3%S8`RwFKEFlarQ^2-Kw+C+XhDWfl3e0`5Y&gcsnS0_Gx^b zc*S=r79}740_uezbzf?EiuU4=rH&HXi+3|d&~UBnJD{qOEA%&2&JT(uR}FtPK|k=u+1qzm z0XBnf7c)?fN8B$pH^v33P6iSZJ0Qv)Pr7*7<;6Pw_X>_iv z{Z`G>9}JI^x`TLwuDz6er(NRe@6h4fOYQR*$u>QK=eH-n!|v9;GUSjdXw@F{w;JM^}486t{&A7J{I9i>Fzvj@8&fuN~jy;ue z{x+dlu3DJ%YFYdbRT6g=>dB#GYa5x{!k;C31#e%S{D(S6>FP_#_bT9j0R+1Mc=-6e z%5VQYt_+Z6S12kPf*zSV7n^54&$2VxeFh=}9AcR%dMg!L=X>n!eiKOs^clhqxw&Te zQ!_dLh?*f!x55hQidxln7{?>JFY1xC`5-EOx06Pf#lqPw*!kHP=(0F^OaW|{inX{| z>X&1;)SC>*>yJ`dtBN|d#-+Q6RZ($fXYm82=83p~?my%l4~THCZfgg6E<}_+F4}nD zNrxgda3`+aKtUOwUsb*&P&MO))bP3=)Mp-V9~C+1YQ>N0UOeo=NIlJSxl|ohg`GGl zITKmh05~`80ibST0X+f5Xl>e8rl%_TY}_-(dht@+ztqHb?u^XT9zY{yCYVAblPvug zR)6{;N_~;fdcZ6x+-3*#O&j|;ZIHP^rGHd8NlhBFQZX!r-mxDD8;@q&%W&JdV75>l6dvkIcxZ|Nlrg;D4k$H$oTs&4Nq+M}`CcN4i0c=-@_Yp>|Ex zcrXar+BB400JSirQD(MI(lIqHaVXHn6n9AIn3|n73@A1hbJy!u>W*RhH(Y{0<4$LU zLqY3lpcwJ98j?2hbV-GoKWZZm)r1$$#*rlQN*qa2&C!ng3Dc z7n~1tbmO;0ZrJ%L25+xYCM{>cUxUh1=F zS~BHB?(e?UlhA4+D8~cXK4$*T#TAy{QiAbVMacOPANy)C0{ad|b@D{EyWfjccx9b) zsg%Xyk@C(syl8t}to;Sogd^Ta;^XZCy)s2^IRINK{dRuGdJ3RuqD-P@>BCq%3KRr1 zld>c`(2*_1A7^~@Ata|YaQTC>a(pAp%cUgF4s@YQW)_msW3Znv8(kDN-Y8vW$Ju$F zxNv2h9rno;m&7N_;9F5k>Vn>|K^GI6+lBgFgf^0Nt|zjg-;&L5d7+_maOb%<25*^B z^4|gYqnBcQHY50vl~w{m)|53jwWnO}+7Ct?p0&QZtOxV5n(k^-L>yZjY27(3!~#CqWuBT5Z-q}<}tX2@S!8BQ+v);2(LOJuSst3 zk+6Oeai$EOfUh(xm%_FfdEzkm<95DbB0$^bL;zFCR(6r5?RypC?%4pFmZrqfZXAGm zX1o-@W}O0HW3s!eU6DBzl{ciu ztI$(CCgp|p6086pEVQ?!TmmWzLV+Two4eV0{!4*obdenHW=~6;=0tfQE~Wv_kcvO}vcvO>?D<|#OSyS;TpylP zk?LtBq0w>q^5N%pMtET_`(Cf-@-Vz$jn8vMc=I`SA-~a3+ZUemN+pkXS2=Q5U%Rb5 z(hoiLDkkJh+-?4ro;i|KVju8SNZ|lGpg8xQD@pzBV$bi0$;Ob2Maen+(HpOp>i%$y z%lgA_UBm0%o@*O&{XUZGI%0z9)C+lW$YD)*Jx|FmyZl+XOzQ=p9;vLhfYt!UNq4G= zCN$I@0>;~h+LFQ!Lgz~Br{Fh-D~8#HUg>c=9OjE7>^nS*!zCl_&7SVJqLlui;E%H3 z78SoeD!xPtN7;)#cgTiOcA4i+@s%OCOU5u*Dyz!uaChFW^GB8NPKteg7Jw$m$MLTN zSk&E41!u_8^KCvQsXHH|=sn?87ud^TGEy?u4t81Q5b4f+3`-&BLQI`y73QJNdVf!XJD=XK!lZWV;Fi zy)oI&M{szuovjz?&kDz1Y_E>>R~f$Hjnml$9#GQlYbz_fcZO}LxCc$Dr|R|H=`tq` zQ>Hnq{ViqG8~)^QuPg0qJ&6z1)1YYC9FNa5?Yzof2h?V#KRuBx zU~I~&s<<&A&9AYi=04)&rZP1LgfumvwbGYM-lM=iazHELPKI*Xd8vD#v>^(G` z_Ac5-k%>iQ(!ldm*r{muv|gg0l$tkqo3R4ZpRTRI=;T>=b$DTWtQl;&)=uz0R-Zko zC_X!UG=cW|5{FwWvKQT&{}&MDWbYX4{Hp*2`ebaTGR zSzcr|W+5y_7E{!DNT)rx)7K!KMVMM;I6O@JSFABoJm%wFI%~xIG2BANCfxxBXX5a+ z1%S5!KL7$aP^}+;KFu)t(qUxcZzJv&{!1)gy5k$8;%l76O?o^|$O_owDf!(^0MV*XQWVa@M#OgAIHN~+Rn6(ptSt;xc z&@hj?n1HL8d{-J3(-~>Z%b#krF%NI(4#ok}EFc#^BHGbYKQ$I=0OF+S;-bNe@Hg7o zeP)0+%V2U_CzzMgg?h?_8DaEMso6i`y9za*G9Ag=79Qa8#hl22`^?vf(Cs zgeE1|QUJq207I65>r0UhAGF@=!&e_xV~g(qS2}t}v#*(skalIX_yM*7lb2BoE3^eT zN^5BDMm*jXpB|My0&%x_^opcMcGr?&fkR+~1*+L(9H+?86cQiB^jB=Gj<%l}$U}Pm zb|T#^sL+1b+vM)BU_9JOn*h7orw zAQTm^h>Evz@|)t>_O+6<$gT`shD)l6s8qltR5=+(X|mmN0hI6pfT1B>71CeD@uH^c ztDW<7&v)oK9x@+ih0Mq9Nzbtzd2Yk20d4SVz*zv4ajqWiNL&seLl!Uw4Bho>gb_?-y{id|WDSwu31X5H-obHoHlxZ^l~BPqOi5J3sR-q!MfVHw&Uf6Xe9rc2W0D z*wF7T@9C)c@~C*Fl;2_pyjLB5=qEf)TJf9@@3?Hjv&@yZVB+6Hw%uZfs>TPBF?-*$ z*%y@S7Tc*UDo`A|=@S?fIq_ST_)xmPhwNNzPt@P2;p~M9=UP`hK+gc6Ic_0p0~ilr zN8)@IpHaFM_YO~nYj3qnJ>Hdg*3WMPj=J6c#p78eBkr&#U|{m23{k*%dXQC2AmhZ6t`hJ z!b6tYvm<*q21@vDdppWoe2*R3@6lZ9ejlGLU*BV&iTNXMiDXlb6&pT#nSFjFPamnQ zgaV(maYM z13SBn3ffjkKWGn<(jYevhS1~B+{aD63!2FPhOX*kC7M;?Dv4?S(A%N6(AL-os^ z1;F7eihse@k+1K!&r0Lg5gIKU$uwGl6js^2y?4H$GpTLxgOUCYZi6|q}lfeJ6{*v zTgq0rENsd?+#x@-!tNl=)3Cg7%Ol#>Ry|^uI$|Gw1h?6bNzrn9wRd%-*?wAXr+U^% z{G)cE|0x&}3(l0%NA1XFzvkiDk3u_6HMc!x&u&GL>C0#e49!CwJ+p6GpzC%1fSgfn zm+KxDBPHM9>Fly<`(xB++T$pV+KZQ^kE0!5mkp0=i#hzb9XUveWzh7~0rZDYOW_l? zoTfeZJYg4~CaGYh<~wa=gSD(&X}_(-gL+qCWeJV_N4rF}uCg!F8w5GVv-Q}Ubc;&K zlUR9jOnCm2_N}z8C+#t(Fwsr*M?2V;n&HfhY}lx5e0C;dAnkF@G&hbNkTs6So1$@f z;VFNz=XxO9uGMx?gQ~I<$<_nVYZFqq24bv5E8@eTRp@Lh*VvtzX^pPe!8P{sOv+-0 zJ>;vGAy1Y+WtaD4D^LuI!-+tB4?{NkAL7~QWMRbbBZW`XQOmZc?P6Vk+f!X;C?$I> z#wzV9^W>tn_E@bK(>chDg|mg(fd&E=0_dnXPnK@XE5hx3A80@9BOK`&h!irESb6216Xy^A&a)TKmSJhy5C5zQ7F1m0a92N z6O{FTwnwHs8=YB_)?xAHIiNX6)ypK6gX1Gx&w$mQdp$@REec5CxR`9cJB^alxo*nc|P6&*Pe{*HGZ$b#`{j3qb#d950?yNWC0}dH56(ynuisqHF99 zde2*~Y^%ZON_ldndP976%1ft|oAjwSkn-{==<;Xn;&IGqY@40JRF007m3sy0MpdLW z_>H(``l|?O+{8C1p!Qii*q!9Y#E^Ol>(`KO9HBNIDS6J$OW6dpDKUbse?MX~k{YYD z`Z=tky)N64vHM?;N>^cwZ;QjI6gZ0d2I7s&3$DlF^pjGy9y7tyck;^h@E=S*OX?nu zp|{(&9_wH^vXSo(-@n1`5Vm+vaXV z;Uz%w$Hsfx6=#)lr0^AZYrM~!p%*7}!iX>Sdft%@ui9n0KPZWL4MW#(DS6E;YK1QWpCxTO8cyR8 zxoMFqk_FrGOlqyvZO0=lSNWVuJ+(bB+8u)&20AdxcffOD9JeFz02wl!c9t~e>Y9b8JH(2bL442M=!R-^Q|R-p;_?rsnbD#7<~}>mUAgWQ<_Qj68Nr2T{2Aa)0Idt~=`kzKC@mVoC;yN>HGSMCZN z1=h+}U3*OB(7(x-6WR4=)Qw@Ok9_`GK-?;;-;KHITG_qZ5U+aOTz0%3s4}NJ(L)qT z{x6UW&@T<=|a3Okh~Wg5RyA%P5qJf zIBI|Up1^#ZB=Z^&a$P8JuLE&qJb^>bO8_+HD*!(MF#cx1FWh^JYp-jL5zoBq0T%;| zVaWO!2`TdQUjnH#%D2!rO@0}hxek7bH=pKg(V3F{S3IA*RR;bwP$p|aICbipzhbO= zjXdyIOxZ7Img)E&bK?xmGM2s-7;!p{XDX-{0&W8E$F>nG5%=t3ta-Ak*x3?zKL9{{ znrtS?2ggv8%+7W=)&<@ZjW+l-njGtq@3b)61OS^y7+@+(HV*`Q1KNZ8gKq_{GRqT8 zB#%U(>!=1qyS=)-n0Bm{;YydAIhdUjv0`IbkTOj+-i>2A@CAkrb-C^KA=N@2?z_3+ z3vvAcV38ZPINs|Dq!Db~&pr1x?pRl#;?>CqdM9*}4Q~gcUq=qh{zNP7oX54Z77 zAo@0CnuOkgm1A|~oxnO=O7{g8;qt&fGh5rc&qW(5DNQlgTZ&uL2Xk!&GvCq3(AeZo zj0Z<{G{K+6UQ43WEs~=;A!v@eqA`?4O5Y8H6O1ZZxkUh0bj))AXMohaAINtdPyPF` zvNs~Oy>Um#Py)aPxSeotU%nrR?rLu@X&(e?%@|4{nH9=W!9=P5AQ0-poHiP<=7gna zgO|TusIhbV1DO3pIRM;CiK~G_5MH zw|1;J3-`mo1<-2BM}g?eOvN(uBUIdLvize!z0pdkY#yt^a?;-eXO-m|nteg@w}6)b z{{Vam7zM@`0Qge+X25HJbb03Qf$-p)&^K)W{0cID4p@c;@&#ZHY=0$S9bf|hIht#R zKD{KVBch6>E+sjbwGg-L4+NHH86H5HT8_0rDgP&i z;?cS`i)p5=C4Ub_CuD)60aguJVlyXu&6#Tts%URpB2E7cl)GvU{VOmNg_hzdbs4n_ z<^f~>7Y0yn)L91uJqm`ea%|T;`G;F6y+5vvF z9pe${@M$2mPcgWo;T5`9))x(u27Um~>)1cB4H73;CVdK-*UGw20}uG$aCgdI^cmLn zI?LYAFcs-2HJ@X;$oj(}k)H>yG-E&8mSHsJSq^Ek0gz@7sr({P;aEv^L)}V@INrn@ z<&iG}otr7u$bf$b#-5;^X3InW#$=<1Z2mV^)l4(N;Yh`a+MEepC}m%|&Irv0w;69j zu`HQFlbK>^_%cv!YR%gaOGSN!Z4{PAs-xLBW_}fz)b=<*p7{!{wWEB5i=hdvcq}3O zbzlop8~rM}Bcx@CY2O6O+F+#W8~ERjQt<|?e$6+5vwK>mXl3~Tjw9&TxW}Yrd7*Cu z6WXA7<+p*d<5B@J57#@s4U`)yEu%Xf#^Vf@*&-SN+SO=A;>YfhEsU*!CXy$M4!0>~ zQ`9VP8MjIy`M?C;>=w#ka`+>qoY@GGctovA;)Eo({E8c@Bx_tVLZSFm#w4RTp`=#kr ze@Ms;eOt1+!-?%HlClpHgSS1eE-;OF zyp;IVaMMka0L3~Nz{QE~0GFswMW2ccku5&8*K295>|&sN>sKROx0Lo*9Mw%4QFjSF zUzwo7b+5v^Fe6!KL!J)s;i*vw@f?%#`o9Rt&BP^?sLBd^p-j6IiIN`zumMo*34rlZ zo2a5rZZAEzU`@4&;WB9HUs( z-rc(vjH~yP)Sf~zyGZyIb$Lo2>G=-#aPgAyh)%c$HjMhfnxCMq%1}Rx z^&VvKgndv+4hL6l>&p!0?&_#GnA_M0!#<(VHx2pt>hM}^um#j-P4@^kTy z>(Wke&dU-|n(XhSqAMe%63kTPx$l8HmN^Ts127f9u8OujF;bJMDtuj73;a<~t`XU0 za}W0G|BP>XX2EyeBPv@h_u=CT*=oXInqMh^{-6m94mJy06yr&XqIu&7iwdg3PSJS* z<*`sCwMlreyfi7PbL<~p{|u_Gu27qUYDvcXt|ZhDrP(QyI-^;|I*Jtt<;FMTV~?df ztFZYZXK#@50a%Ma$6%KCLaMD5x z`w&brj;LhLyNjKMLWSl_Nl2CYK9VURRqIQaEg`iZzGq!m_#W1dF_|j!DATsQ=C-^% zS8@GrbFONh&xS#?oivWZ(u6-xbQQs6adDX{D?l5M;w&mq8(q&=TBxeBC?$Vh!!MQkLbd)lUVBOr9O^x? zvPearZ@Ak&_7$lc@XWC~tjf(3g>IlrTeWr?<=~01Dz)t?tXAjl1P0|{m(P0mhii&a zGhE$GHTXWpx60ITlc^YwFjSfEfHW4X=+j0MgNK~mRX5*1rLMaYmwKoKCh;$sTcRSq zgOcAvmG}=O$#Z`~qnp)3Y2PO@w})Ed`!uq@2lVDDWkoMFeB5VV7Qj*u0QE%nK6le> zOJQ}`bliHXLzSurppNyWYOb$9I`vk=9cqMjlrGbIo94Bsw+bV1b#HY53SH4hO_AH@ z@Fb%U)^R`Uqk3U&@VCgoaTu@vuK-1vhA>v7uNt29g-2*B_)gh;8{XSH(pPoM__rtB z)LX;s2xh=#s(1e{k;GQW20RX6y=y7%X&g4q#$#Mmrlz=td$deV&$8|?0ocDl!=(bd zN=-i~5H{FP9X8#*Su8G-r~6~L%W`m5^PdAbSd?QkIv$YR@zVd>G?2x~W%UE#A);>7 zJjY}AK(T2~R^&c%^rGa@;CT1S22t%n)3|3={%qC~sr_YA$V?dQ@D2Jl%C;!jIW$NO zETsOezEf~dpzcYPDkzfWgVZkHS2ATV2E<>33NcujI{;Gw#3Vm99z&49>Zj1~`{<|$ zBt!rG0KmrCYpRQ5!`^F`hoN!>6t(Epz#IpsT* zC$9}t7x<631SX%Po;3A&5;BAV=K{!@vtCnS36ywS20568$H5zYBtyjj4xnf({(yXPKlWTcHAWSnV)u+u(J$h;qrb@~tD#v|HwnOh69Y0*&6d?C z!*|~!n@`3RhW0|STAJ6PlhIY(Bl(q>uHFY*$j0}Gaf(`{y2=a@*kZ{FRZgRex(Va@ zl$6cHxmbB))!0_UE|y*mh^nk^EP6&WGUW0wpRx@fr%E%d@Kg#j;6(Lt=nm7RVkFik z-x{aVbIB2_qzJ$t(Wn(()1>haScu9SuTJx|mzweDgzv*kWU53u79@4eVvo+>IDoC) zu*}|rMN1CAWdXUUq5koF*)$!;*-bk|%>dDjr?`WN zl4ySasj8q^p0ISd8YinAI+kQsD_QXcbJyC&y6pI9 zkn0Yx@&-?k-nor*wtCuN&T-PZMAMR+gzSt9eVDMd^BCl-yP*$J{lS z2UL2snC@lDnQ(zrbrBEQ4ay^Ds%~zW+u{m21*fWPv&aVpYoEr(B<(C!?#Y2xZ(g>$ z{wy`<^n!S7P_oJ^Y$L5Z(rtYf#ivWc6jeHsyjo92o20q04O%@ioqaFOCJYjGxjV{i z%@lXbAyN%WH=x+8Q52(wr>9^{RE)G1E%vv+TmJ+^PI1W9q4`lSk8;^m*6*I0n{ zAzt2lAbX3d0$w)&)kDuqM?u*sXU|qewc35zs}-ZIc0HE1iDDe1RcP;c6ckRTXdy^4 zOi>`)ewmNjC8IVDw}$CH$k0MSF*`W>B05fO*hx92EIt}k*j-Q^R0T_=D*6G>mT2ph zY7I-QV*1CElIm%ADnP6vSvO7P7Y+ahi4AnGgIuD`%?5{ZV)`~srJG|6tv#|nDe5!; zT^W7E;P}!I$0op^Rf$#a5a6~jIN(_IvJBEIZ%MDO={S!?aA-V1?)D7IYtvO{BQMUw zn2yCMuiXtp7A}u8%UU`^<-6EbGgNS#7yBe&w`gI=Spc9xSZz>~!+~e3BihVr)7+ye zk!qAZq7_Oj3mw@C#WdEw=UAVG_l!fi)gVajIg}^@@;v7|K9*>1x z40fn&SNx3wSR3Tu#SCD(l{WGzadyhnBs<3$y%z-4C^p5u}TkT|T4Gw@>CKXxOq}KO5 zm1<@yWm0iojPjvh(HMV@q-aSd{PcP1D)3QuJ{G|_kYH`F5L;VoW#;)xaw#(1&r$%* zmZr#O{^TW3>V^hF?Kvu<^>L`OP0DAf>9S_F8Vc#Q&QiN2`4ZJNhuNql6l9tsNBvR! zJ+rYcGx0)$UwwgE-`+kCCD{zAtyX0+@ggQS%udah`!7@v%UdQa%P(S4)h27FYE{)D zYf3aLIO*E3_~TT0akfeaOM9x-t}HTd6*?C8EGk8wxfnICr0HU;LS{?-EEQt^-GXfn z)S_%xTmr1OrREa#j4Z%uLxV3v(s^;PFfPn=FWy3#Jtr|(cNL;909@=Qb0}#cK1&1A z7{{xZ6ysQ&#KjYb18g6FCQQ@yhOgyV&l_<;9KwXS@R@Pp@p0in2v-Bx2xx9};nX#C zjG!?l-X{U*mb%h*OoTMd#T;nXKpg!wWPL(r!{XCZ&m_yF*x6vZh`47?dcyvI?f_O4 zEw~OqQAv=dOPgbn{IW!Lsn&wE#rKoTw5TCxt(k7?bl6I#r z=#Zo##Y{nbS#Z~U6-*~Gf6D=QoBXIGU#!kHn(XSS~enpHH8 z;d$H_%poP}Isw2R!$gZFx2JGSrXcNPBN&$>2eCtQ!`(@`kF}Iiq|s8?AB=*sM&Zi3 z;LqZ8;GV$z!CMi<7Gk5VksUWq4qT=}rxTSjvox~9Pi|4C?9(~|r~{@^k|&Wy=jV-Q zo;7YBykFVmFUe(As*udmLK3k9s3+iZK#kO1junbjM3260mp_PSborfe2;68y@J9(~ zbU|Fl07%|S#rmYy(&h8Z)h=_S3oRrJVA5ECtwB~hi>IQk-uyT}8k-XM7_*Zk)Z)ob z^tP;4m35$5@keD>1RBoxG&^ZDbdGNZ)nd)5gKVkAvt@gTc_opEjUSm?B>4+fsa$_2 zHhj)ns5)m;fm9N&R32Hm?x=k7C0@n6YoQvHO!;ZGcrrJ7Q(||?eo$p*8QGy{Vzc5+ zSW13?jw{M(^$)NTc%P(Qfrrb>fEbqAE7+4pR$QT0`&^`wt5mhD8IKRS-h7)seJ~pY z>(^Q%!(#!gN6JBs@j4p7G+uF%MgMdP87U&(y}bqxyUjQNd#)C# z^UOjvYnKY)l{7sAgoBIJ=vJ@)(q{Q1?lPJ5Lv^KZjBNg);;ysMwHRoujm*4OE%KRD zkG1Ss41JR3P^s7*U9nuERup@ua%?4}=8c<$@GFtSOH_idk2l_Gwk`aZk*9|=F2siT zE(>rT%H-?tAkLeaM0ZI27yMw!b?OY?oXGy`u;Ns_1@UbG)gFtNiaI>Nqh-*0QDaPI zja34SHjqZ`6iHJZ7G+PCqjhRZRwXQ*^)=puRVs6rxn@=>TbJRv(pV|`vD)Z4bf@vr z#B#~I9&4FvrQ&)lRjrk|*Skxa-a#I|x4qmTH4pMiqo=rdD)Oo2YF;i|erGU2W-QCi z+n4IIQiC$>*Eo>sk-bi8fTMdHLiM*7ec8EeOEe%_Fq`mrNJM!Vmn!RSP;-mD$rHTE zKq~?mbQ$;)=)#Ly!05!W8_C29gF^1 z#yQf$j#q$fdsJ^*4ALrM`K4*TFS=Fh6&XGZ&lvXIs8W5e$blO%`bd5XQw1veRHhe?vDuDjsnQ-mc)hU#Dz~qm_m>_R#{10`n%|0Nw2q? zj!Qe=E75Zu$h^&W5AYD~8;f`uy>ooVvB*dQHq#>#x=EFeSq4-pihi2FWY)~tE(wPD zI|*TyNt{f8#cMD1clm=S|H@^H^8}(~dr)r0$3fz``D|B9Zr=J<(wE^eaR+?Yu3_Ib z>GD*g?re@Zw8E!=V%@9F2UaxVd>P9S1+WaQbmJLEPf2dr_IaiMA|Ac-xxgb$rZJxB z7N1==@H!gAK|r*`(xt4)UnZ+=Oi3@MV<9mT`J;Pq4a5BX1Yt6lE>$Io!G?WYiys9Wcz_ORwRS_T5n<=#H?>UkO~w zK(>fanuPm+i;Iyj>|T3uq-K%W&Rz$S4HNlU91F#(B|aNph$C@^ZJZBrUTc5y^P@*O z(y~JW;`jC7Ux9S$Bo)x1oqSi1>D0uP*ospmyZ)FkMLv7gS5QYLI9Os|{Qw^POvT|h z58%iVAC4U9g#$o(;uMk30sNdMP-4s!gE$LhUS7Q>`YFD{=wK1R^w`1l%)LJEI^d~9NSN^PH<-+zc|Gv!oSh!76Hx$FmpFR zG$S87%FVyWBb^&psf$eqf3h4}rB<5T{!&-3CYWJV2iZ}t)|&xHrc}M|y`2^`zCrCfzIO$NIjI2@_a^tP)w7N5ofeHDI0>;DMX*hKN znm)V0vyg|COJ!K@OK?vYK<=j;hbGg{ZcZN`BhVcQER+aSn-SVfpBA4Uef51hqFeA4 z{eIkxwxiE!9gS7t6TY^6F0#?5#e_GnZP(32G~G-r8uv6F{usxlIy-ct9&H@58TaCi zW5cp?c$fIj12Q`UZy7X7M0YXcG3xGogj$%E1aHH$Nzy5js@r1E81Q7Gq{Wh{mxJ%i z6}hQ&IpS!F6<7$MmCOPWHdnfjc#f$FFxktPlqEnG`D5nU$lOAmt)ItSaBLJdBT~7r z70RyLG1RD$1GlS{etbOdlcmYovP#rKwEv@`2AVAk-fAM1i$H|}=$T_LC9Ak@|}0P6PP%Rwpwu?LKv}&woikZrO=(&zg^Lw$fYotFC^`4Zm88dB&W`><3kv&o@_U zA5u*?$h>MDw!>h~w)|mi3NcLK?CeL>S4dj7URC>{>XZ#Yc~2@fsNsEH0t@j#mBhy} z{8U5Ze{cZM28?)XWCw_tHSV!UDF8qd?PdU`0d4@$^w}LU-Uu$G8`a$0OAtHoT)*`M)(^nypRcAg=P&m{!8ZQlxg;NW2m>g^NZIiu$aatLGe186ynv(+3-pp9Phro- zr8pEq)%oU2T11Jz21(lk-6O9=)U!VSWdXjAkSCA)Ud=Pb;F;AqNoH61==C^iw(qor z)Yx00uCdSmC~*Wn*r={@Gn72z?g;T7n^7Wbp25_6TjbC)Sd2jXMl-?zSMMiwmRF|W zW$J_5bh=#s2er(9Id&)wz?=Dbn_xiOq;wPJ)Z1jzCRKh6KO&pj^dlWMtF_4Z#Af$h zlhbkZn%eCfAKCaEHfut^tDjfVlRMZ@t>b7uBrUqfxZO2S5Xi!SPg)61nvSH7J|Q4ET%9e#zMaH0m#K zPV1L1s8hgo#h=uYEEdT@VF`eAh*vAS{)D}XzmO+hRFg99#+-pIp%g&Fm?~*ov5s*Q zj>=_ozzBXQ`g-#?kz3+yU9ORpp<0wmZo8 zGVz@|Xt$_)+;KMBn2mcBacqkW^LL|^zoh0SFN8DXP_!{$mc5ctB->xY7_`?pNvV9T znWotgn3dUnEHI2tp`WlEeM#kK^&=7dS|%AUJ#ibhzOu?#ErkXPc+yl0PvU(Koqm}1 z!QXhPdjT&mzg3l(9#`7tZCEcvbKZ{qZad`AFdcp9Hbstpip6Wo6@3|tvf-di*`a2} z-o2iHBuAdvq1KtkR3&qFx-W}W$*$9}kg#Sy9$mb$Q)xGS?@m?L-^(m@N3)<`rJ4Bw z{CVZCk~+MTFE`(XZCv{l-snsgotkV}!dKz@J*~PlB+p9EU@i`VV`O6Ql2#^d3O$0m$*aG-FfPH=? zfDMFZOX0vaAG^MwL*_^fnjm>hl!`y%bdMuj5_BKNktgz)4`2gfHctAe7s^1H@z<`h zVb?XGOWEJC*%kn(0gkGvJr>R!Ui<%*s|Bytm>vd@69V(_ItIWW>z!jr)zJ96eEDz} zbipiSWSgYCs>)-k!4WQe+3NaN)x{27odH?7G%3`R8nCR>h{gd}XsbfdDXQ{@?w6;_ z!9T0cIV_mq#bfD8>fTkuWyrEX`l%F{N??2efSRYu7*9cLxm4MB09zl^yfj%$N;dDu z*l^-&s&gU3q{(Xmfb^I@#t+_G(Lr;d3+K0sr13Rul=hBd$qmOGtVDX$AE0i?$y)j7 zHC1jNlXF^K03dPJGi%YHAi}%S9g@61qg^fDt@;(ub8%ue;0aT)m4Gp_V>cc`<2gpA zT+zdyDd&dqA?aSPn=Y{Yb$77aasl}M*VPYA=Yz*RZ(!%B*$y3)$KO!V&$RZF#&1+8 z)?1$)NqZB|lhGv(-=ij&_aLdNLO?ZuQg9)b4Z})AAIx-m0L}-lfI>#$O6mEFDrd(Y zH9Uvw4ET#F#|n*M%wJShj(ttV`iR)_yfoeJ4>@+MHc8h11;h4Os#^x0pZ-PV7qi#1 z52t9IV*$2y$%;wGDJN>eNV=PN?yqc%d*IQqC}lItk-r{SqLjBVe8R^J-coz;yrp`t zS}q-b?VHhu20?zJK1La<-iGkyzIN^I2W&=de*iciW{Fdh9XznO;%!xsLq}nKO#$w~ zldd-^z5I7_063IO!j z1jds`>)fbeR(27yyw0+ zFiKYAwr)LQSuksvhRVj~!~0ct;`;vpI>ZX0Htv*){g@qlI}vhCt2Y&gmdI-uK%Pxp zbYA!TerzdPD~I>160`JToe;BA$Fb~E@jkYT(!Ek$R;?{j7QL^^43+*sVPUi$QnG#c zB-!%5I}I8t2SCt&m6_;uksEJv(*0MPKv4&Jm>fW~aL$pt$kGqgDOu!>@{*=y0UtyE zK!tOIZZu7iW=1(5!=?n&c4XI+iTPv5I7wO?8IOBQ#a1+}^q4pj8I)Ag%4ArgZaB0X zpQrdx6`0{m0iqHm|DSLvqZZ-&7;A3929P6zl2Q#1NHlGhWg7Fwm1e}U+3#EDN-62w zh)265Uz4QjBTt*X{v*uDnKn*BXpoZkch$S-YE-u$afJZVvNb@pF#hGk@?29wwpFh=Y-B*J713Z=0Fh~1 zUe?*1&$SFSH{m4WkH%wlg$I_uOVkWkAYGE|I12}WPyRMB zbzC)QM6E4aK2=9WP*A#7o5pJi02($wrrR_;`=5jl4kRy4O3!89S%4jYX#iTM4?x^y z(o~idx|Ae(04UbQ0A`_{3<}umgL_)17Z1^fcZXGY?~BEztn+|19aKc$eImPt%b7jOYHgF zv^-Jwr2fdZO{ZxPpR^ajb=mk1vMT|jo_!yy&Qsgs*W&R?KB;$BBW11z*mO&u4vRAI zM;p(V+P+Zox8JGMEVfSSiS^5TbfHNc5`=k}?>STrlbMZ05S>M^+40wwIHM6ymMk0A zX0%q^Q1K2Z1>8upgHc_ZGla(tzc<=CTd;#o=dvFZ-hBbloI%F{I--qjb43#YJ zWR3+;aQkr6&QKEh-m6Z8!e0BkS} z(-;{h!!~T%KEB)yU(lg5z8|{p!xW8eXchldB|WJMTVcc})4Y;7t4X6Osn60uqX$+7 zd1U2KKK|au*v0ZpdC7tTP)_Q@wm;k&@+^j|QeV9H(%S6O8ishf8PXt2U^CBH!{rE& zKgw=-Bw}Gh{hvb+?9eC`tYdXs>eTLH0Bei2#NVZW(Et)5^-KUa&y4}_HxqC%z!qT5 ziCnX$s9;L(15ER9%=9oHOj0CvTm^t?fVEv}do&;c5Ko+pSfHA1I2gJY3$6BFm-kM1|BKN)#$i@+|bwiSZxu3Zx2XkLr( z^7XJMolF!0SYIre_pDwIX)<1WlB^)?zTl9J2uUmfNRzS~y8+d08SGKaCwi zap+TQSs+CmiujqTGyD6($U-is0;oA^kkDLs_;W1%Pm&3r@T8b8O=ou~w9Utk>hqkt6jP}v=AIlQu_uM3z1E^jicVglQRFe>W0|+Bou{BoXQ*P-fL;Xr%L*;URl@H)v_fq zOmxP1J>OW#f58_r^9$3*NdCb1EBCGi^vhI_R$iohUp=g6gB>% zM^tGY&oQ-iVu@2lq{NEgJ#Ea6U=3xEEJd8HBsQ%v0GLdRI;Kx17}xGziEC;OSKxPy z1rRnJt(J{P)lBENnBb6e0#&^+eb-L7l#((5*J(9C;dtT#psoVBw9+{Bl)631# zT9nb&EeoVSU_G9U=Yt=Wu`p*b1XhWH=9CdkWmf$dRez=E0GGI^S0)M-%m= zLYfAtQEG}d4`55`hkG0r-Ua(1y1#(g^{m(Mgsi!>nwM&*k`$?$o|Gl8Cg~#MOK|>k zKnF*Xj4@DLS;RB|<)nSvB3Kq)W99nf3b~NFqy?70+RVRzLdKaNqPccl6&QFlorFvvSvyObS%~c*dE6LSdmt{ z`M763rm+dxc%$`(`u#zp*`c!QBrGZ1yhEoZ8IRb|Sb5OLjUpH>GAZ6la;;F`jI2^>2THU&vzRU#GwFUNzp zrK!4G-EBai9cUZ6F@IPY5AkHcOc!;u0gmvzzT3Dj{7KV zue0jz0@CrASnU>K3B_B(-6u%D=Q!y--3_pHKD-f<1MXO_Ea(&frJ-b(1C{`O3J}19 zfF}U&0R9C~FnJzm-4jp+m=3rQumtc^01qyI7_c2ct*vRz&@`hOtM$UJdGbx{o)06L3MM*OXm^*3POs7uo$q!V6Q?Rzf%k$Fi{dp^ za*8A)&V6lg+Z}1du^jSS#bkjTrT_{7qF`tpM`oz>#y_XpyUT5kYddt#IaPmJ== ziBZc96tII0V`V01B-gGMDVbG_4px0-bSLyT*q+yl155rV% zy}o+nXtuF~))h-TIRAGpJ}ZH?P47*6{1wWyPM_gNTp3A*^aoe6jpvJW9ND-b zkbk~+-|nx0PInfMj%efRtQd>Ime-mWAWSh^TQgNHi#zIqb65`5K|7*Jd(}vGyHr#Qa>BUClZj`1k?URU!*N{+A+%!cy14ZyaPZKcpvQg|!LS6J3y#WBoM_?{5G zl`WaLb3Wa9_hFiF!pL0cLy@8Lf30=45Xt9WJDn?1+CjsdZsQl_3EYcL>rtIpagH5uZ8s9daXv7OpXIsX31gnjGLZSap;vUdTTRi z%G6cZW>A);C*Xr;i?Z;Ar}>L@=i+P-UIw6+IC`RLsd8QkRPCh_4B`mr@#_*ZPp8bJ zZrdRT-?V=_>SDDqE)Q2$8-F&AWiif%gR-Qz4h^GcW)w$Dv;>l(thSbEZ?szujKTo^ z412P1mJUX4&(g2@{7(jC^c6ZA8!GC8I+(+C2mV+bEs*+S8FOSKl7Y1~sAqo9?a~uE zYo0x~yE6vn+(3v=D=lz>k;yqa(N|1a`+_i;wz{#5TRHp6qAogmRQXV8?4m3EzYWO3 zWSsf;Vn42OpM>#nmyqsl2B#BbQpla#<>GCmr6JwTES+S?t_K3)*gl*b*&WhNb(~qV z>Zq@=02awzy!_dFvPJe-Wvn{Jb0FOrSL%~)%nz`1#^c`R#ck}KdbD(0ebyO5?D$BC zOiTc9VB8h~8nz`sJm@mUOeXHVG-!h-rU6Y;SRzuQ%t%$P#-~%+LULt&o(`E?oN90y z<{g{ff}TIl(`V6g4cIZ?TKC(*Yu>?2z)SOW^gwmI&)pl3gx<^7y-k&q zRoa%-Ke?y`kP}i5%fJFmf}*!I1z;q4d#ERs(>kQlMv>r#w@Tkp!tjFQGFd z6@?I~<5N&p52Ue@*xn+r_iq!6q6=ZK73rIfv8}l_3^q97PLj=UVbZfHtUG((lfeFF zE#HRqSS%`3bkhTIxw4xs#ig+uCe4#%b2N0In+}ho47LXW4>4(}KQeDSVB%TN$HqVl zw3_J^JyURgu`Vz=>Bo=83^X5WU_)n>*e-))+9KVSZ|Ncl-F5Ut=%G@ETkhyJAAw%b zUGo^5mECoXsdzHN>a!JJfcq$OQT$#dI@54ASSm~0xp+VGu0XDpp-rY_Z;1|@y0oHG z9{N0+t*eB3=u$%)o7(v*LGM^~tE=R{C8(@3#cyCv|rs6~LVQ+o5QAw#(^g$mrM(X?M z*=F(2s+pW-0ZbXP`Wu|YXp6&l9Q*3%b5gI?X^a*HhXnV9Lp}PPEL(*`9@g~LfA{|m zQ~VF`cEJ5*x;GVFrl+?!FEv_Hc|Tokw3jK3{dA50_vZ8o-_sKAkB0J$Oz*Gr{n2wG zisY{TSlins8~f`JE<5_`(pFDz*?z6h!`Z7#@D}$;1N7Np>Twj(3IOzb>~rY@*qrF5 zd>ASI;w)7-j3P3UKO#&8(5sW^asYoeeJt)-y%c4e93G&(&( z8X~^#l`6Ln)EAhl86}4Y>X2s*zHFc_Y1NpHN$18v`r%gCtlSzvw3&v->dArg`f=tXVx(NRsV;33QbY_ux_c z!8~*htH$D^_Zx=kRBY6rotqfUpzV(XSa-Kb4t>ivtrx(OD!M5bGBz>UddmSOT>nWo^KK8=2tz#Dfu;;bM)li4HTMXvc& zel$`K@Qs#@BT-!=^2Ik;B8z%^RsFOa{1IMw%bV)gN%X#cNvVX9J|BmGKDBlU94WSBzDaI`y~{AnI@$ z;6B-0smuDGj@uf*9e_=Mj{!-*sQ}av7eC82t7oC)kJZs9^!PaRQoM9DYpfpO(5^Us zOOgW*Vh+0W%>->e0n&-wvh_(Y?+X=IW!5icgbiJ|Uu5!2z<)lf;GDy+u z6rI|>#l%fY=IBy+G34v)3rNiz9m=4ckYj3>#6nWH4AYwJr|5p>SgUwR<{Xhn$Lc)a zW+^*WS2_i7u|~C0cd9OHGlwsl!(k(2d&XB|mZF5or|NFbix|PhvSZ)nMBTY3MXLnZ zu8Qex#!3A|UDlo&Aqs0DPfC7~nBU%dPP(uja%iGn5__$@@9j8!d;aS=P{i;@3_A}A;-2IUOQo{rZ2h`)ID)g< z>1+O1U7PPkIXYEuX)f*mFVD8MrQ^~W^wrj&#^64op{WD5JWkh_4K_86D5{V~#nxfe zcOup9_P^A!m~^jy#2~ru984r>HVM()DmdRDy-&4Eo}(_>F%5;qad60@8TJ9_F>!X+ zIl64vHr##*=z;ia0XqQ6Fq~pQJ>Z`-BK#@=)=6-aOoEg?gq_GAU#Qa?MlHhj^Km7lojXU0kCa&sj~Gv zUE#Ek`Lj;vV?fL`EnjnEDG*SqluhSjEWS`W&2p7dAQiK8qs#|aBex@mDFr1J0H6aS z{8(H~E{>*#uelBr-;}%+@or8D-0~ zzPcRS{2Fmm!NdzN2=6Y_FVNA~1ZWd1ll<^%^IAPv9_dZF?n8R4M4lpv?+9n$Wx!W1 z(4!rmEXgtxC3K;#8cZiZQY1^qzvFwTK}q9h5FtMnwMSA8~{??rD8lj zog1q@L|Gwor0F7bcbjpzzn<>Af|nwqETvtd%Y46;ic8=F*O-g{r{D1tv)Qug61hdO~(vbSHi%f4j(Z59==m;p7&C{huC|(U<4}{Ob0yWB-9ye&#}~v*utC z0bgcFmp4(C!||6f3)%Q_Vz51{=n6=};p9X~n};#_A7tP>ec1F8lcg*L!?}r<>O1@k z+DXAKyhicurFuqEber1r`Pjk`z1=fk*X3I8!}_+X3p5=z*fCO5gQfHv<%t?ymDCq8 zJ{-V?k80#yrgcwt9mJ&3)5z#4NEjZ#cnWqYCQhm@)1?NT&VY7HYhX4zWMSXRY-~$o zr13I6SW+KNN%*U+@@m^CT)wqb{(NGT*V;rer@dQtcgLe3 zp&J0zWEwsd%vxrhSO%#9)->bD5r1s;uY(pH3FD*MIkW&n%s1kTXnx>Ibu;Iitx(#0 z;`D}QN)5<3(AuSl}y6=g3Cr_SfR6(0?LN&rbx`x|Vx|F%~5&f@d<&WI}n z&}~w}EE&EKt6X~nx4-VouCs>?hk-iqW^4D)pZ&;%$V#bew1D}W+&1VBnN zAt$b@Dmn89I?LGyb{UCJzyAP3#`*VQv+1;gr1TtO^+E!30&U>x~GAU!n<`p`e!@h+ysLXxn?wLd>{0)td<>%11 z7-XE-a0O0HZuDSoYKWAv4eN7d$f(8T)smt|@FQFRVAXQHf?=*x6ac`CF%@e@Orzp~ zER+(yCuvvV!6nPp0Bd^Wm+dqxn^)t}(ZqCrs`R>Acf(fZs;jZ+&sG$WMOW+csXRc8 zV%UabdNPCy0UYJ9)G+|EOIFDVv$G2g1DKDtXT@gGSoto(%E9C^oEK7bjlKcJuDiy4 z>`)a6Ey6U+JZq&|SPt`3BAUy7S^Yzu-y)es*yQ(3viUNq&CQZ+@&|$2`=@k~?$_#j z&0suHc3g|ze4!k=77c=YYZgx(~Y$E6Y>MB{g2wobCtT6 zY`9MAoNkC14Y&w!9pEm&a|GFS9hM3f%2(IvGKa^2)3THdT#BLJRWiFy=bKS8)kiQD zEe%U`nLIubM?v&G1AEu@EyWmlu{14)75VFQSLebQozgmYzh)5^JxXO&ot|eTFl!X0 zvi&Q(1Uq1v?q&umD8QJGcZ|cf$f~DF(QM4pL}eD&5onRLe;PE=21r^K`XgEb+aH}2 ze_P$v37qe7Du#MkUdU|dP=V*-lXP$C+YOs>1HVk{n$;Vqq)3|`jVxaP-jj_#)}`a< zD*OOa9t)Tcpf+fhX{-8JQgoLU%k}U&c8%7_Fl!hL4(W9eXou7?Jw2lwdKe+VDhK ztmb)dt)I@esG)XjNZz|aUy#!k4UK&n#i45_5cOV}`4ddx%z95)Hv9w|X3g2o`4YGh z59!&C(xhoyLa9u?5zpt{)vFCR>NBGERlX0UYK5-O@V281(IAo=HeVC!S&AYkFq?@N zgVQ5#c!(TYq09296J}vWIY6;tw3>E14&%8+Um4Qm?^@U!VXOQuc-Zn5PQBGQz4m+n z`>~It@g^Ory8%I>k{o|)5PlLsa#T56t1WIG-k9(fHwIyH$o$0TZxiwopT80}-G+1G z!tD+pO=}_I3*UnOJel)TJ=8oslD@yetJ9N5q-1uqJaWjl17*DRrR@BvF2Z`tp`YTM zpL9IMDFO78w3~IX?*!bw1t1qR3g)6T_F95_az(vw`9|)(Afbyn&!xK?Pi>5gJC`{b zha^*a(&-^9Z`PF^Y2?EIe}|=Ukny6HpLI>{Vs`t`PR{@=25bO)1jvAvh6AbrKLc>3 z={rCv$~y~iE#O%IkB!MkYnlK+vg?>SnE}nYh&usB02PRO0bX&(d3H&UPi|w zOh(5WM(Zr2H-gD{AhYpt-zOZ;=s?gphVJB?p$Wy<58vFR&I2QD0hwtl{&;cmjCd=X zI$$~~S#k;j?Z3A<4giD40y255w6@|s49d8n2^sR{;gocTb~gx+C}~3za!>1I7QeXw zek@?I$4YA%FAIm^P?_yVa4uk%f^1>$Hy~{Z5VqZk94gZND{{~3EMLuaPPY9a#=IQfol@&>2ZF1;*Dv+a8mK>`++u9bw6`-k-pFAxaE}3fkCo6Wo=i@b@}UX& z`Djst>!iU|r3XF;JEcP3S74h9*VNbv8o{ z)>6K&zm$cOaBg#1QYxNhR}ICqv}0}(7A1Q6QcvxN5-`^=BYSf6A?{OgB`5ZJE$*r1 z;Q(?(du1B0Hf@lUg`D6eUWJB{%xpaY%tqxio4vM$n}>9=VNIIu*50!cNiVgbeq-=t z%N+YR3eX)_1>lb}Xf}w80aRlWpc=p$ASaAVXczh0&H7t^`+o$Q?EtF}FJTvxe-&nb z)L^RQuhPq%k1a}M{VIJR`e`gjR^Nh+Bz?ebxs?3^PZ*gYOX@ERlu6!gzRr=mexZMz z;2SS#FXM#SqFZ%l7EP`YVEd<0xKG64kb0Nz-bmH$IweV_O~amx4)d|tw{&~*AbDi9 z{@OX<7C$Gl{%)){Isdd_`RE=z6#W;1bOm;9SRcTZg}&}-m<1q_merBeCcDt$VsiS zCi&wv6TrFJA#i*)u6L0I{3yjIh@+dOtvwEy=XsZO)V;b}#-~8AOR-UeL%-7J%d7Y5 z$r+y^jiNMXF1t?$Gd^!S`ir)s|J`=^Q<@w(snyZGfXxuY9+Z4%i z#o<5kd?2nnfH?fI23W)q;I<#(hZ>iitwF092>Pv2g zSMxBoYmm-Gg}dz@M|!i)hb$kt)~ypMl{_H-7OnK5MjC{3PVfoj4;cm zS8CQ$_&2&dBL_(>%ilEv4+pOQjUJKJ#m&~D>B{ck=#rkc7MYdm8USEPA!Ok?n5UEt zD5Yzw=$Z{M(%e>s<0(47_kmW#jlnG$+rI&;V)=;nidvv#=tiB_LfwVHp}6dkni*NN zQJ0uCDJGHEqWBUJ$0mkmA6p8svaze6HvfsPf~Ii;fIqqyYCP<+#WdnEo!z`m?-os; z6|16RM9|fZ2hd7sSYrWHBpGB?jdR0HBg5U1hiTR}AIJSX0GVbTb&&9*y1b~w<&)_ITVWf{HW(;`T#^qtuU@$npX z2P=s#JAF@(UKXD&!+(#>VMbV)*?haC`F3^l?K8Novx@N+J2;*!*zu+hIYD~)3DSo) zr`N?Ehr}gD8Ee!$5@18 zq@R3(^vV;Yk9E_{N>E!iFzy5d#-AX4!U@t(iKf>zd!0BVJM{zvCY~UD(h1T}GwG8& zZZD33(@#KPa(sGpW0-aK^g>lYX*u99JCnR9XS718kLZDe&y0@-wGu!8z#plf6^|ok zm^lT}Ej#o4-|76pXCvC%8%%Z4=(g#DNO2nCS`I2_-<%N2nBIyaw@8hg5g!c-B>*~d zJ2oJ7Qa&dhS4yAO<#p#G`gjg-<_XfzJ3;#S$4?*7Zr1S;+RctnkAC^@0z|jeF*TBL zVXJ5(yJVE+p zCrH2iIO#rFl9HH`L@Qi?lLN6exK`4h)fLq_amv=gx4gli(ZySFLlw&vgqZE#&yg&VeV-0Fs{91U)m{(%jMwem~E zwVW)}Jcqf;ZHR8+JR2I%#pi^c(_K%!9Z4Lmt_E>7Bd>P>wWWuA;*YwtXf>jHAemxO4R^5p^xi{Cf^z2SHO#pAmYq{a!I2}h1TkHa|pjY@7=sJoc=!0@G)Td;_* z;pBu&ne&3axA0yNB@udFW@2Z<@gybS>g*0F`IFvi&JUoKFxq-DZ+Uh?z_?5ok0d#W zCZtMj&&2YMG(5XbM^P?nC!;@0?j`%~Nzge{5y2nxkp{H`ZrWAK>`j4S7P(_yMlmnN z_up29DV33CRnNo%$EKA@*%%+zO8nTzz5oj*g?5r_X;X!yZ^H?<9a6#5DL6@Y1e62# zMr#(XR^r$f*%3DlV7phEBdeW;r2$4nIrJjtm0l&8N|B1KdTs_O(=cprRwJ8V!kQ1G zIV)(6ZrX~q1xB+8HAi=PNr#6qnnlN=DL#G_mda#>dBup~Ni7O9+1YYq(Q(-+xy?@L zVtCEGa=PCf{n1PAMmK!jVVnNQd{NRG4YArX)R^H!4Ri8#J)#Zetlo|n^ja%t>vmmc zHuB&Z=ok2C$*fOsZh!Y3`i1{t(Hpk}aEMbDw&Bg1kPJmqh7|b5f8}Bm-UMF zYk|g^rD?2=9C}$d`sDtB4!*ZIMC-_gUHa7o-$PQj8!siTi$r$oPX4Tik%j2p0G(r5 zo8HhV%Ks}kj&TWHB7t}GRgV7=C4YMnhuq}##Fs|z`cR+Z^R18U|426|->+rSA-rGl zo54^WZ9;Dkp<|QSS z2~IfUaYR|y93{i;^chso6JAmgkg7?@coK1Jf$S6vLlRO>O~!8#ZD-6bGmT044Quea z@FwM)k@FPNTj>QP+6fjHLk%5zp<=Z&BO~IHj|nEbv{Rn(J2yI3gajRDQTyK`n)MxJ zWVPdz^?%wM#RBkS%SUT8CPKNM0Zy!d$YICXnBaRhvcA1jmFWM2YFIcpTRL`hMkH?n z9z9O=;9D!QWkE;hZU1J}AwL7UuXjSKY_G&d&4~-}l4d987XNdq;khxRXCy%0gvp@c46 zP$!240CH}-sr!;-VV*9ME?u48Nd`$Kb#VWCL*G2- z47}l3m*+J4x5C(0sV?&7VyCl1*Fh!|8}i>p>&kboa!3vgVpmDoRy2eT1x~6dLPhcm zoCkbS;w94eyks5utk6mI`L2!}Epm1z__rzP_g-QbIoRE~#bil~EH81s^7*$bS$0Yw zPwwjJ{LoDZ_Hruy{vB?@;@-~1Zo>ZFPLt2S)9AOmeB9R=?SEOx=uSy_k%?u_3_tb< z9=acgYi{cAe2q>QBIV1Q1Du`ySKWs6^g!q03#}0BI_UpwcWdJ(AdW(|70-^L5Wp^x z)xF)9H}4dtn~YKL_$NIe4p>N$nas#a-Xx?t>PRhyDAWj>^lki zPk!A-`pnmgm;OD_K`tKQJPnoRk92~*`y%Bdok_j{oVyPOuyBqi=+ek&wHwED+AkU6 z^$qBU=YHixc8qdn`ncQr*>$Ml4?8>Qk+ViSGkiw3sgaFia1coJUP{L~;plBc{rULV zRTd6ASvt-c>%3{XG^{s_YSfXB$H6p>VfaxTp5Sy$2}Mqx;GFF@JG*g4S7gJf&J8}_ z9@+eX6Fs1dTFa2xlbl7Sl#Y?Tlbi-WWUQU+RMU!fS2skP10t+I4jvMFuoHxbhh)k&$lmXVMnI9Mwu!{=fdKypYA;BZ;Co^ znRYc^s<~)}^CREiq-ll|@xL22zsQDjoX$SyJu89iI@f7T-fx3G`6L%RS2rz#+jwLd zcjgOTY~D1}xqwD+o>OUDMxq>=;zYkUXpAqi@;oQakE82W&vI(pzYk*cb{zTbl=|Mu zA*8JDog67<=gVQgwOTr78p&t?e>9d4B54=E$owA~LGonrg--ghG$gNG=zJ~He#@?I zXG&&6mp5=Oe6@3iLzlq{DU^yZ9<7>f{cF17IQm!tqIlR!>>XR2E5HoKQZ1BA+oJ>Q+k;7LwVc)+b z|4Jw5Kd7YZYNw0bb!SrQx>;8`KHs6p?5mtTiT+QNJX(gMl+L==ndko$ip9J@Uc1)0 z!~dC*GoHX#pl@F6oaX<$IncRb)^Btqdx`TqpYsLyVa@zos;+~XefA^x4tm||yy|lj zn{&g{%BTmOQ$TpdgHEk%=mej(?|yui4QzaJzjHslPs0P~ADzIlGOhHZIRdqd^nJ+D zUS4`VfYv(yBv4%NkW+vn>K}4yleHye8g?H0E4(JM&UqV_m-eu8rTJ1tYGlR3&Tt>1 zw*1Oj7mbqIN1XhkWf;w~U9gdI^8kN60377A2S7bO`iL_NrKPP$e~AXx?`-h4V7*h| zq}ZaVwt=#JJ%$3NE0>K=VVFIt9AmD$UptvNnQ7p!osCf%`QrbLQ;?i$^ZFXnPs)~2 z8gEoh{*Ch;kS1+#W;*R{dSv4Ucx$@NSIhi3iSaFPGRicKl5_l4WHWBjz z1|zdxbk6f-7&ctGyib?<{dl{ZEiv-(Rwo_3c;xU)&LLh8Y;{6v@Wq z#Bjr!&04;E#X0TdE^a#efzB@F|HIvzz(-YN?Zb2@o%FpokOY!+Hqu!LAq0qkfQXRB zum~tYkzENIl>iF3DZ>< z-)e4}Ms#Lg-|zRYU!K&hI#s7mojSGL+jZ-z+XP&f0CdzPYr+!Q4@v>@VuR+P?E*OL z;Fcz%lRF>1VQ^AGfpY?3COS4CGj#OI|1=r7>gTh*lJ~kX++E<6+rVQa+mz)vvma@- z#q^ZD5TM3cgkOn)PPrBD*mb=G8xuCI^Wy6}uN%*)d6KJ(Vrh5-X1ga1qr(kv81H2k z##4j@-!x{SwRgX%y6ftTLJoatlBIMifc1#8- zxE_PR!YeUy^?HZBJ6!p$G2dkrYaZc;w;DUyeDc1L?7~Q~_5))J7PGUqMb>I9e?{*% zN_29WwZoY1?&Oui>256ZcNiDBOT9Ap9E=Rx-^Uoc_#@*vdx@15p87W|Jl&nqVlO8Z z6zSI1t*W(G7UiwJi_mVT@rcqI@3(Pi!Y78`-9>fS&hpxJ6p{Oh@wU4hWArD+1l)$2>}lIKI88#kuUeYy2^uDfKy-;J978xW18t#)+nixZc=rFHgl+3|NH zZ_o(5ZNn+Q0&oF65a#2OZg!Y)y^s}NG))%LP`sW{#MR#1nUifgXDjldGCspwJLJn@ zOUG?M9MkYdNyp7a9MkY7O2?(zZ~QRK^8bY`axAZxm-pR0Uqmog#Eq}CuHEYhGdo?1 zOgI6b?45eM+nc4U#rOkA!(P){u`OEu!=Y@)zj~0($+B#>QR)8idwG1f(W@QT&$@)W zzQ_AhU4smAMwnrrE2qh0V#0%C!sYf+aZdeZ#H4A$(Q&br4naB;r&bBjsr=!?gtoHg zOANku%Z4v8p*$!}UmAIBpL5jWM%nwNA!l6wT1(3(O)V|sUvFvoAK=S3T3QmpiXv0x z18_2(vxZ$`!p%4$&-qmCeT236%)eZk|6%w#X1{q*f0an$WLYXDd$7Q4{#q8fT?MCa z#ld?{@^dlaWijEpnD7vU+oR+ffd0tM2;Wt`$;`d|1iEqkByNul6@EG1(ajqrDhodokQf*G2og5Z84e2O@HdLBMKH~Iv zL?d|S^VV|Dj|orvyd~JGZFcX96y67gQ;5E{-_Q1svHkwGe=K}w+YUm0XSg&byc2uA zo%E*9{H-;)F($#E!rQ(<-w*Q1Bx_UzI2nwy(>t|9%_EsIEavHpG&GYl9C1l@oHiY% zdkv?GI(c7(u&rUa{5vCk{9rqR%uw;D<#vq8m|};WLfsM5{LdrI@p?dH+9};0BlH_P zBSH_b%b|cbivN3~U&mfHiKhloltqB#{I3t>qrFC!Yl!UKYm^ne@K)>o zmHBq-R)1Woel%VvPe=3ZElB8tcd~h#>O2fj4UbY9*NA0aa3pe4l`2< zcHr5-fBG+d8CbIV^obKCbqAj1MESO5B*zBj#}E%Di@C}~26YEL4n9>!6;;WcPx0jb z*iughzMk03qgi`hhZir7uf^wPJC}M2L$kx)%nYPt`*WGz3n&7{i+^~6&)`a?3y>fi zDlHsniSOIVlizvrCn2uYqkFbRfRS*#f8!nVk>WVW4?<%G;3K&jDP~HI56ZwhJ6@Tc z;7K`|YXd*P`cXiJdHczA1P!p%4pSoD1fB)(A;AbB8Q?7rD^w4tcu5W5Sd3^8(R5P) zvY^eAMIJyFEK0LWl*WgX@;r*GY`6)}!OU3+DSht3TRE&UZIk9(0+79C!C!xP!~z{p zOCsAgGAGUSl^!t}QcjU|Zjay4^~ZrHJMopUeW&9$p%kgT0uP3ht~4`(T1c%I)|nDe zXG;M(N=`?;1$Y5RGhv6Nqc|Frlsp0eo#quAUjP~^m!xjDlEr_M>BFggkjsw~X9wJ5 z<`uEDAm9Q503C;uApmpZF{HTjLM9%2&n`;vw&l=M1u%VE*|EjU>y9hc3LGuiLUdRN zDz%@8YqE=~T{aZrrf|=lCTiKx4ws?zgQ|FYsUoM2ohwM)?TpffzpIM(pGa&JmS zpP%_=Vv2fSeo;b%Ns-iEV3f&d@g`Lys^htOf*XsZPsf&BqOKx4FQ|$X*|9evFY*;c zsT5b4%>I|*?O5fFj2GN&Lr1Bp92!loH0(?8xvIp!4;Fvy`9{hJa$-+#_9-qE*j53s z3c#ll*dN*FsIg*z+S9`lji~6L2=2jNp7xbQ7RN`PbK=y~nhML;R+}2``dZGFhIi4| z_zGFhH3(CsN{tTAZmE3LRU&H!SScsZLK>>vIWdn$982#8P)a%zyCLZ7v>d}YAyNq} zp99ceu=ApwtbHKC7km(x&R%d=Ojr*7e)>GYb5MW!QNY!#tU z>G@<*j_fJ%c!x44K_S_A&8P^~O>X2w8fO;LX&l$tbf%$^lWs`OI+w3UjvZu=90Wji zoRNHL%p){pPt&ZyaaQidl(+V;e(*^**15YxD(AG_2d)Ml1#+POk-!w-Twocn7I+`{3P^^`nZWVDc;I}X0if7JfC8jJ zm)W0amIPPh@FOv|Jq*+2zA7ElT#$taImW{k1R%8~gVGxGBUUgPzc{n9x?7XfS?X6z`z zf8x3BK96}+^dv_#e4B63{n?S3#;-m}B$JcOV_}DxD3e`^{;vfTr|fWuNRQ;+uD?rl zve_@|eZ*1$&f)N;1CsVZQdZV$acJ{Edm2Xuv13vPY{iqIDb~|zg|t$(L+m2s4S6~E`xFxnb#!DHF>`rfU~*Ql9$_{PM+!~_93?pXB>=?$nMI8P z*BnJ@zHBI>Gr%+y@YF*KSLIO{Dvo87H?P^vA$);~?1ccG9jW5V86j)$Gb>%iH>D=| zZhF_9)`#Ofx#=plGFik^I&DT;x>VWqEKV04hiCiP#uQ{$k}?5SkQ%%apm2<*TMAG~ zT&YnJq;a{!Ys$zL<6Kb(usE$WR;&onVv--hasmLHoa8mrgVZ=3iG=_&u@J_yVEO@o zgC6U|ux3V$v(VUdUF>uejDnI*VcA-`8y<~oG?M(oYqrI)Vf(#isViUJINmIBb(E&# z&Ec}?coRQn8RjvrfwILgd*hUY76VJ{f#NgG5@S4aQ;^6`fr*ivQ&Y^eqD819tHv}en(E{7m*P|dJ*6Q9_XIhzA;qjg`7QJ&NljZbWK4$G zY_lBM-PW9gDyF8I*vr=qciUgoU@Pj1cII)|#I&WIS&^ev7eIQtgH=SP3Zxp4YL>W8 zklIu;FEbGd76KH8ZI=UNOG7HEt90>Xs@X*r=i-ovh2>@jhS%mh%)E3iGoq<+T_sg% z5IsX`(@;XT_`Bnm|9jHRQ`IN4b%ogs92lv4+JhEU8+bh0V5Fn6x&SPZLyo?4cG`*V zLz;(8b7N9&?r-?YX;L2AlL2FR>OVez(urwV4O$9C zq9R!a9hJ*7SY-A8GYhAeteBPT#mKfU%N*&e7n_A?mNdQmf5#@3#HvgJTbYyKTMBBxn=cMD~~C~ zU0@#5eI@Em>+c3ocf@k65)q1ogbFEvFN)v;On4$Mg_ip*}H zY%DUX;O#HMiuasowu)lRD+6VIu{qY59*x~vY>tY=_6tugF^_g3(9p@Oc6}pnbwWz~ zqNEbEnW_D=B=U%y>+&on} zufpfwKGw^O2e-Dhq{}13uL71?_oxcz3(Pfl~{d@#G`IA@;R|?@>Zp}5it!%MPnX5%6!(i z0AjG9oN%zGxjeFCHaVPnv>A$Q{PxPaerC13FRZzr8QBBw4f~EUXC<2#+PU?4-FrHE zyx~7qnR8uk!zG)m%wicd*vxi)Cldx^!EwCoI35pO&_~+K0j^b!^(BvycE_7nr>=zz zbeuU|ZSv*h840DFS!X1a$rjN=yxW|<`=zL(N~G0@$y2o zdGI}}gVFn|u_PcDJ;^IB(tC&<&9&9R)U$?|6)H6c!B)|EMKroofpmbg2bpqMZ=EcB zV2JsZ3tg;vm?`j<4L57y?TUEAPf($C5ifa!S?jqI^DrLKUyO&XSB)^IIm1aK&1>Bk z;f~{5Pq8e%(acYxgC6}&pZwUG=fg4K+Jj*(Z%~mRu`}l!x&Oh0j35i)sKN#; z$DW6~fN>Z?X90_W@z`Rs6yT>OD=;zK1ZY8?!k!~8ICNML<}DSMs`UK;b-`;YoIY)c z4Pd8}!ON2~LkE_4C+i1>7Kn75xC#Nb%mQeiR`yyp{=u<@*#f$yyWpByqFWmAqAR8= zyf=K2TaLXV(I0kLU5Zl=1ORek+jC9o3RS)8lP6Cy3yp;cGJ1jRJjtAZNoK%k^VuYO ziS$tcjuM?c6pz<)e+MnH({jvbcjyGrB##3o0@MO)%aunp;M5p?fp4MtP!x`M%&#k@ z25f|>m_mU0X8<%gYIO)eZK5jDr@)h$$powmiDWtyNRxFnrazNWg8{lO0LyWQD(Cvz zsw;$4CfR|+BW`x+iiMQ`3tL7l%(#MXVSG_xEVhc^eV&Mc8_!m-?QK^P(5zKy>_~6 z%SrNgql80e|%>v&D4?`dWyqa4Y*0{9qejW<(X_jt`9Tb-D0`)rg&aTo#@p7yF8+EQ<pG7jQZceh~K*IElA7Wo~M50Ox0T$16dJw6{HGw?2YUm>KLV%gHjP=s; zWuniZEGoUsS&yR&3QkDyrn4NXQu9lb;IyPX7d|f7-|HJesaYaxqf_W%m=;e1WrOJ& z7UP<9=kMPf+PX-??H*s&Qd}}yq3yHNEsp$VYD7m!ykUnEUC4#gur383O}F6+T`bEdVLV#`^)lHIX_|;W(HN z7ol@Z{V~~l-tnN$2i5~&U>Cr`sI}ezoi5CIU&7YV&C9e@LmfaNC};qnql%Y8iU9m1 zY06CYXU0qN8<{m30xq6xb}^|A4wF|!eoY+6^n~u{gK$mN(XoqBJZ-}4Ary-~)AtJH z?a#w|_Z_B~Wo>Ei)Hh|varikNUq|v`T8cabVC%6p8DAnh`r#dU7Qx;^wh7T$D4SCe z-dlSr(VNQ#Vk$Clw&ke@DPog6h8IQ3a|mKZA1& zk=8aU0OE&9RS!JDMfrvJ!f){VM4vn5-zrItEl*16L+Pj$`V|0;b|+T!x(Dbnm{L>C z%D83c>1K)K=6EvHcf?pTrYlk{EIsbWqwi<_n3%6@Og=spj@N0j;T$~Ur6pDYtc&tPl_&c8&>+aR z6Tsn|-I4ZrHRNDC7sGT#Kmc$9?W8Kx^mWwbP&$(6x&X8nm(0n-j}fzTtdxPh5T+72 zaE*WxnU7pqYsT@K_Qo2P0yIS(S1(iAS$SvXPi^CxL@pa$p&bvdb)TaKsWlcxhJjGa+ps2VC6lSAnuXo7 z5yyr|04O{gkpgOCsK+%&l>pF2YW|3NkA4}MpBaoXe$Y5Pa9bc##^K=;>5&x%K4c@c z*Sme#$qcWzY`Wg<4YGpHGlOVg*Fx`9z*OKBfUU${#Qvq@U&8gdz+hkjz%9-g)e`a>3^D50y{o?@q zJ~kQ#IPX(vPi;K)MmC;avIA@X*Op>4&7O5;+SDE{ydvcQt&ibRw(q1J=^ELT7M8;2 zwa+E5UyIjO4?JN`^z3J()J#NYT5)`mw^evp)eeUp6|F z+hzy+Ujf1Y)k0YBpRNQ9>ZcPNN~fl%MD{7#Z%AtYWX{RF9G9`A*(6PGn+Ov1JdsIc z!<#ri;F{}jXSrvfd8)zgN@720`jhD!sDqV=qNBxg45Y7n9ml?6fTjBY=HZx$mjI4W z@_E?Gb+Y=Lq`ZNBad{m&SO7j9`x5&bEl`(4BVm~13gGw6C>sZJdy*8dGeX8{!Pa603BPVw27nWhSGiU0R_PVmq~Gh=8& zjKA2SZ~_ujL~Uv`P=>XL0bJ9ux=YnnUa48gdK(bZqPEW0b^_SR%gIeWlAEOu!`_vj%tpM>{S8*mG#4 z8Wp&v;0y694eeM@JYPa2f^63S&j32^2>wWw@Slzh)D-KWyX_KO(=kpPi(Y|IOB9^8 zewtKu!g$K_SwuF%bgBsWdZup|nscJBovs+mxiP|d zJULUN+H~f!7&y&=m7(o1nytYKYOc&10O*{&Z;J572T827^0CONECGqwJ!%kUVbt1E zfQ}0jkIY(vdy_pok~2b6r+Hf~d{*FR0S-h%0Sdu_I|CFXVr6SrC*`GUmXx(Ki&5t6 zF>#r2a31t9SCXuso>(F)mU~iy-yy6eqOm2|xCj1bfHZ9@+89}C-G2ve2!n1{m(Iqd zhMoXe+hI3}RiehRw)Y`OF<9})xZW`bmvpQ&yG{|H8wOjZ&q-?C-m4;Q(ow67m1JSd z09J;D$H>7OO(jRDHth49fl%T>EuPH=rv{uxK*N%lkpRJH0W5GNz^V)bxN4%$@KAs} zo%O&0PpiE?HNxE-kw1q5>Flfv?Xw(EJM_xvRH35(9j=i;rFdKvX8OGd#!KT_W}dOuYm2PzRLeOAut3d`g|cvR83d3! zksI3bEp|fO=uQc}d;)gJO*7LxwA8i|yaF#4(XJ`PQh<);Nk`UNusqo@7_Vb%Q&kNv^E?!cKy3Qf07E9|= z=b>40s3-;|0y-VlK%G|rY=dtk^@Akeh-_T4X1c+(Q3Vi3$9P)2Y76)QfR5ta3vpPi zdR&B8X0W%0th6LtUq z^W%rYn92vIp~e)#9w62ux6+oX3XbyKajQ2k^sXx-`u3nMGJs5U)XRO*T-d)?AzjN| zX#*)Kizc`JfOB^!2apLtet`PZEiu723IKh`rq-{ zf1P?;f-vKT0MsqzUI0+ep#bzA>VIk5Ni?YYZG(#b%!9btAu|DS)H~(mwQg^=AKQo3 zs|VEb1Ae*$Pw@JNI-8hTCIPvCAD}wfyv#y2j4uYX88Dur*UN^@I7pX^04k8RECf6< zeSKotxL&xd18A|@s8Ao(8TC?yQaA^}aiG&Ks0>z$y@%JVfGS-!)R`6CH-Jw7QLGym z<*_EkI|w2GV0Cscew$h`-0N*W1wrbG`tJigfS=Jic#8Y8m_-2N>8NAYhPBd_r}?oO zY>N!|Wq?O&zE1SHI!kb6g0FjQC8;7xM^2i?$_@uSvLPF-zyc}&7L21C)Xx`MCrrjl z6a!=x%Yqdt0@7ve#fEPjTVVvi?h*vRExN&qG%W??XI3@~<5@q7fao^sZ4o$7kzOV> z-+6uGXam$f?S#^3N!++5Z7M)kG-b9PT^E4OLp48$=5nf!X>h*g1zw-}Y!gDNBD#{C zqNpcUj&VbPi2%(GBqa)cC!Nyj;_GltSCTZ~O^?WGGZM6dQus>HxCKk+n;ce5bQ?_8gW@)se(7eYOuJA;^*z zsLTZZ41j5<7D__fD71ZTAC^=+oLJ(13}?3C1n8b&lo8vaRLtXuR}$e`(+^{fO#Z}S z*gP30o@_a}v*K(#x)qLJBuf#df+#VIUIbOLM!L3$m+PJ|jlOJc9oY%j%*2EmEQs;W zjyv&R^3|y1+#owY3#Y~Qar~0UJXEo!@daqcu^HG}+9=pWO948TM}CxtU5)8!aI{3q z#4u%G#R%vms4T1=fy)67<}4Hhb@Me8J}Y(?G(HwSnKIl6+d-5H>%3&neDo;*eF{mR zT4qIUJP@o7cRKF@W*cm~Z31w$8n#=J>#;mLpeS$RVse?^p-Kh%}%bv$;@^Aqx zf^{qhNY`oEn9c1%xHcmC58$>r!PE0%sRYH-z zRE_<(V1IN<#sQHEqpON|N(*|b(}l##$Kips)@hw4-iXhyYHOu7ilrsTOz!z-qz@oS zcJb<>MWI-njl8nseH=u5$9{Pr=*cP#Ac~Ia+2mlwq-+ne>>$?cWWRgCe!gLv8>DHn zN!fH$AQY3(!q^HdO*eO6(8#tij@B8!IZixzWdrnSUgSkFvJO_>jr+o?D_lPJfqin@ zu%u3Uq zY_rw9gV~srCQ6?c$h0)&fk?}^-hgg!>a7l7JVgrtboBt^STq}+T|NM~Y2s|Q;{oVO zHQ#vnoq%7$2+5;Edu$=3X#pr;fDv$!IB1czR8mRpfka=B3%Gb?(=zqVKmgZtns2-^ zKJ;H2DimlsnupJJ-rzC89=3}}Z z+!9K|;WS(hbOmU`6q8k<;nCm}q;@wJ*qgAURDDB-jHm)KC6u7NkH(LUL%k_M4u#Kx z35A&oyaLdE4gjP*7l-z(O?y5L?Q@&)+*^i0oK&E{?#tw7vA?-vvoMneku)`U4c!(Wl zr(ybl9i}V{A7_Wz0~uz=L3u&dr5SNFa2CMpp1?WwHM*;M5ts250EOfL#BiA%=AgrH zi5=#s%CO%Kv(gN6(ZT%e#SHtnpkPF@9YJXs<_OFLWW+GLI>YSN4AWw>AC<$2L4gyOsEI7WT{B;l*x9V=^a6VxFlqA7TP|qe=#J~3s3Fl zB`2i}q%hUMQh<(4#<-z?mVp{80w@Jqyn&p+vC)vFXDF`8Xr{i*hhyFRQ%r#6aVpH;&;Z0 zuSdbN05%;}l?bqM0YFuCCcL;r*>F^{e+2ECc1afi+_n!-DJGW2^4Kf^fKDqD-;_zl zOY<`j#U`TOV#OhA7DpC?0E$X5%zhXE=rqfK3PtElqb(zrFO#tiA!?AB?vUSb+dQrv+uCI4`@!3 zMUQ$4Wcw?YH-}c&6QICD0Bwn#@Vc#2MG>M_PKI-a0%WR zt20x&|NSSFOg8M!QTq&4b@RCrq{?*Xse_(+vYEd42@aI7HHU^$pZY4nZe34lKGVz# zjejtsNOuob$2nGxN0@!EP8#dD+O@p+fWbLtTF#f?L3^StQFs5)lE|Dov!oOurJ8Z@ z*%jCvT8+%c1%}P@<3j8PAY--TdQX%OesIEj9?+BY;(lt~kpsv{$Lcrh#4HYujT``2 zi!`ah&(8A27QDH<_$<6rsaxKD5#*V(%xvQ;%|LdZWro$37j_mJ4Es}w)b7Xm2{=VG z%Or2AHoVA8u0oB;i@oQaG_;h3%03y0-$iP5zRYgKt ze=Qi}nTFOtJJ!a2tD`V&>#9Sj-{w`9)qRg-g6d>;*6R|TT^bkRkaF07i5(OxRzYtI zPd2?A9aWLk6$cU8);AE@X=~p)t0FbG;)8v+oMWcot!|vAP*Ox`SPOPzio#mxFfQ8^ zg&Kb6lXKcxX_29|c)Ix^^0rLJnN$m;vL1W(n4E)bOAjVk|`hh?OnlUch%m!onDF9ycz)6mi zI6Lbk96tVt1Lk!Y!8SASrnocwF2anb9GQTovB(9q zuC|kFJ#Vp}TWOZ8_DgsP175T(uKuS?I}Tee3Krp2q`n`x(n1GLO_5=nT-m{5B%@TF z?Bvwab$E|mYZ1XVKj2+=wuCP7Lxi<9S==iK(;~SBX8Z`inSY&~p5+t))Ht<|xkJhu z-EGqu$-(A(Fknaer-aVMsVF~4<#}eEdXI;V-x*+kVVB#Bl&a6jhV#q{bpl0#>^RT# zxfkF|Ex-5VhS4d$av49`>2hTK(4?H|1Z7cV!r@0V`=?IC%D|NZY?*9;lM9=o9^g2E zm%Yw4%hbsr`?L%c4vw{8a0?5&V3af4Dwi9J;Ko^|>pL%C|3*BL}Uv z6F^}t*>Ju&wv_TSIh*EiNxhPMfm!ET5T12`Io#!8gSlk+l_qWsFT^OdKsH{4QR-sZ zeUVC4b1}{|QSZBWWbLK6)yulX9HU0BNEIr7!`EakHB-WUFExL38T++LrQhY|YU6+G zV2*6N9L4=Bat_YLSn2&k9JhJ+Hie}Q?T8%yA?-Y|0Uy;yG!HLTlkDz0e;Y&-mR%A=n1dE)aZ zBLy*$`K#s%b8KHG(%lc2ZFo{PZDIo8!mPqJ;_WhZP0)bRe*DT`PCYK!c6tsXuUC;D zCqgfTR@W>vk4h(v#j#zPf2C|&XjaOm$=Hd;_HHd`(?Tu@_PfpONXcCEJ4<#M5*Uud zSNoprNi*2nvVbMBqJweQK+r!EE@>mHzq+PJc%y7F6IeL-VgW6Lo1orSc!De(E z&>1vS21o89BC4ioQ{`Q3zYe~(IBJ9@M#tJ{L&oCR@&4){Au;8z%pc{i##mIkf4?%dz zZ*VM=I?yLm8qUSR)z{pOeWq%rmk!I!k{n)AHfn-qq)I?shSV%Gdl#{5YDLw7%#ua` zEGZ()oy*LMKFmq08UpaT8qii$V#f`&(~c+B`~0l_7JkHuvIC zuj#)vEA5!ozcqv9iFWOIC=6XGKr5ns)&pAZ4pM!MIYH&@5MFx?+T~zVsX-xMlCDKz zRG%dSt~FQZu$jn}D$sp0LT1JURx%I%oGkXi!MvbmBk@5+s?Z- zWX`fxo_Zrr_((Qn%*e#f(&HPv5ZmLCM6cUx$VU^6&T{{a=835F{u|9L5lzdMn{b+w zG8Rc)g>SZ=BNeO68Wocm4z9w1{Yuv4aP#lX%E-Y@UMacN-03#JQ+*=*_vQi@emcAg zhfzKDd-G_wX{@?8p|iAKW1ir-3r*ceYS)-`nLM?KgAC1$X2yn}C0o~EU>_#dT62l| z9D9b$zYW8c*)B1qh&lX76+6!{C)?g5mK!&T?%T{ll{ZVuZiDRHBjO{Qe(vw_Nw$R; z++V)U>{4Xu)_|7jw3btJymYwT+-0|r+?{5ROumpxX`CH6QG$2kjI1<6QtmQyGrM8U zb2`us$!P3!4Km;^bD2Bckmv3)&rJUqtcQ-a%&BDn&%@U7oxb|vPd{e zUJYn%VdZo$PNicb!y1)BDHO?!OAfc(Yc{%7M>E3DuIG?OB^%*g_o1iR*U9&r%M;|9 zlkf)WJ@;aN!6hNZKF_rL?5epsEVWxrf4e*ck3}@I zUI<9rx z#5i%9_V4>p?ID@NRqvaYOXh7e)9}VZL={8+S4xjlILdL9bx=KrNEt^UN5(^I6({|X zdCDvMJ*G_FW)=q7CUk5kZ6w2S{VO4;3ZlfiK#2htrEQ)(Bb58(;hRy9h?pO8iY)X5;54rKMI2I`d32mum#-#LH0R>IqH8!D72ui zsau*B;k{jT;6)FyzQJ7p9*xk;kPE*ttK5l+GRBAd?OvsxeAiyt^^I9mz7rBspAVj{d*AXB^rC{|z4TyZ67rC^{Teqt@pFKaWTF zzVFP3T>X7eA(tQ==(v99@XJ){`hQ=gysi70D*a?HR9ZS5Ch1gZHNvr0I#2!Z9pn=} zjuSLoPB*+}GyY18wg0{i9!XKG+(|$ronK!Z#t%2|Gm|}PzG)lY-(ps~3p!!+4uAn& z7XXuldhErKz0{D?+}0*_bRI`zI*z!Tq%y%;lK3awhsugVFMeoGu+m(s!aEYIXFcxD z_U!YdVZE1FT;||Uo?T+X<%T@c&g$jvYRKp9tjF9HSn;P?_t^8!s5DEAZuSI&uW_W| z$HfCj<0yiH*S$U2s7nFb0w)CYG$kIF@r)}1*adk_nkjkdR$e;i6K131y`M{(mg42N zbJ|-OQ<;1$z~o%F(eOC%(fsKDXOO}s{9gMG?qjfHNkXkrR59Ui>f!#JNGow)Dz6!Aanu}0cN0xSJ~kV_?jV^P|T#r>+H;* z!-8V-tMt;m+w|pRflPMPEXyY;!h&CxQpdFMXO1AC6~knV>n)8x;!*hhU*b0eeBtp0 zoY=Fky_M}M4tMBa-RY83Zp4XCJnuIAW`?yO@@&l&9_zE7b-TM8;p|+it6M$hWfjT* znm8XtM{aIYm%04mdHL2;F5K4kE3hiuJq$Ukz*^<5#PaJxBP;7DD4o>{0CcqPo`!Vs zTfI8+{*i70K)q|;jK?uHkAn9qzxBB**b5O|kbow@d)3}C;iF^1ePY6WW5WGn!pFpf z`?n4!v^myTRc!TWKcIDdo8z!lL%e&S5nB0PR`{x7>qOTngJKd@#e@Sf;lVNC<72|r zhIHy=9bYiSj%O2}15hEnrb327+mo?Sxuug;=pJUsQ=O~=_i#sK@d=LH%rPP+JkpW4 z@2D8!i80}m9AOuju~A23P%1^KHHK_1wN7b2#!jQ#>|{fxb+!r$o(1b!ezhH z=IUa?XT^lijtQR=6P^yeJZ)sjlU>k6^?2NLiW@)Vl;fo7eO;`h+%p_8?RB%x1P@Lo zIWGCCBVNj$d;tz(U09CSxo3gGff%0B-~ zq37s33_jAY2y!r|R;z(uX%S%0#cCM)^%n#jI}ZZ$*1}ZWvw|IqkuCtx>E1?j z=2-P7d{N5sdG01nT5iIpuh-&=4aZSh-x%D8Yr0=Swg1;@#N-gG#(3dsxv+<|AHUVi zsl>Y~#nMn|4TqOnpX3k!P-$J}Hs-=~mC?(F`|;VCRlTga#`)2>)ZW(o4#Oi_Rcf^# z9myFhJsoBCN>AG1{&~|W&+!i6=(3ggO0$lR1Y@(`aI}?SKYdt#v{fld(~{EEX8`n* zym+eGMmFF^q?X}Ml^F+X5)@PKTHAY zCDg;ws<`GogeYVCS*vCI0N4M6X7bCLOqt2vV=Pg3Dj5>$Z;kD!7LI5PcJV{5rQrb1 z?8`mY$_Re_S!CZy1=4YLs>jv@uARHtVaBx}4ZP^DeBT}1g2(7KEA6n(!?^j__U8;g z9~16?U3n;zV>}9r!(b5-I2lMJgG%p>5nwxhv%%06{Vni{P{S@?=kAE*Z&$i%XJDTm zXN(j(j&n@QepxxllbimE{d0~^`#YI6z{+!9fR)lcNyRXaH~?a0PHDz~uvP9V~|=!|Y#PwFKMkpIVvDxmWcD*>;>&jqfr02U@+m z`s`G!QvjetZ&7ao^5*kGNXZ4vl?nJXwC@aD#aV*L^&OIPWK9R`iu%ca9(8*!4IS{! zil0mvLv@`bs|VqB_aX?xs?a7M0_x?3K~`D%#fauj)WPVMK~`n@C5UG89gME3vV7^6 zB3f?+iZEGQgHNCjIxop9E2^x*^ve!O&{$>pqt666sqv{gC$w5%Ixq*g6bJ&#fCfN- zwZJ-H0}uupffs-#U@Nc#*ab8Ldw~`p846AXe1IP)2YS2O$mszqz4UAZE&vt)R{*z4RPtvzpmlRxCsu@ zuRj9)h9l5J@#x&Xqy@M!Hi4wxpX5uw3DF#PqrFd3-^JHGR>hB&_|Z4VkN#c!=v(4P zuRbKY_JO3lOg=BT6{OaqsDD<1Pmz9qNG>J+nnR+=tUsBpjb(3fr%JTf+mNQ! zm?U|_Fq58gAoRf5Su%Q<ccyW%HV zlZ@;`j2s=W#OmT@fn%Tlq&9vn=JiL z@uTmLAH5-Nbm;@J(a=a4z(olcA9O1vb%f%_Ap3?nwum& z;q4TB1hiI`fr6Z~)uTtCKXwFq_^0W;+C2W#3EDgnOON#PClMW|;Wx&Qe(KQZ8}Uqk z&qymf{m-CraeZ*asA;i$F_%t zJ+~8m9bPiZx-hZrxwu{l(7!&^{KEe5o-x*C2|;$CLZqc%44*s9ZUE@GUgS0THi9qL zi+kBnaN_}!mH`*<=5s%~{?9=0=Op@HNprIj5VOh8kn$I$VM7f8^fRcFIS9hV(^3^z z6IH(=D8yz*dBLA5d?ym}1Z<|c-1dJe{m-Rco)EDuELJ-!qnaC|qNOO1js}cG_>$E6 zw-fXJ&z}0&^*Z>lBetT{YHZwpKMbu^$^Hq}bPqct`urp-PhGZ`4U_O>?6HZ~QLaYW zHPI@AmpaLs4{!M-JmzbZ^^>eo!P6int&`%?Iwt_X;#0K4>+j#y)i2X~+=oRilPw?g z$@i8Xi0yI{Lp*lU=A_Dst!pPgZKGdOZ`36v|9Q?O5?@0r#Kk+d8nk!%XQ{b$OhXGc%vMf>DBk~`XOVZjH<&J@ggqimP9w|VwPY-`P9g70j<5D%lD)GFDXrHXD#crO3GptiR!=PEbXL&6~nLRVCYw_O9{F&Ag z*Jf#%Y2_7lz&OJP9~6$w!W%ojlhze}5s)9{Cz`17-kofQy0oz?Hx<;5r}#{0>+P+zqS;9t1cD{TX-`cnRPW>vw={ zz~6vfz&`+w3lF_ZT#@g~^@l$Mmb ztI4OtB{yjD#JJ=}O`Z~$+^osx#U=Y^+oG|V4wbw{lh2P!4r=m+amgDrneBfl^BtOe zXoPio?V=FkW^%hJLbQj@1qG>Bc$se2Pz~pO4QH9f(9% z%(Y5Dt(j|;sZ~%1nKRG6#EZnZ1hHwZHCz#kq;jshkr{BlTBt8O-|9`)=Ue?0y^GG_ zzrd;hVblfK*3c-S3#^UsYA#gku2~n_{QJn-%h<^-#Fo%TX}r*Cg4b}7O0@nWo8@$} z^h?sk*3qC2xY(}5bXFoyF1c9UY*k&NZXX&iR^slu*qVT}j8sw$5dS=ub3S$%&AY_P zR*_Y*{CulYT@I2)T*|&ntbAqPe8EdMB)WjM?@O&}l^jQ8p;aiVjv1k2nlH7hcEUj| zj@CMvbD7e~YIuszcvine_FQIVfLX%jR!BupibQX^-0FhpU6(5j=gqTf5Slg5&b#O! z|Lb^}=P81qb+UdQ*0hb%g8HheEJZATjf?53^KCMRsYA)NAS+R>mX_yXK-=e8g+UtO zn)(QUcvf);|+&?=J zN0arq8Y}1*rQg+fny@AO@YS$}KAig6BOT?Tj7l!}td$=~1vrDYN+&yBv&u4^(R`A~ z1^+AJ_uw^<71vm2xn2x^dkw^Q4GWLD7Tpn=n0}pAQ_Q3l0Oy#i@f$x&r)G3q-2wTk z0o$17bxur?(aV$Z729>Ll+dR4)7qyX86RN2XxA6-j*j^=wrU=`0-HsDkYy{Z@VJ*i zi%NsEe7H$-;LjE>$Dwi2McS4)G_Os2MK&~`lYQJ^b!q!5(osoV-{wlw%?XvV{nUhv z^h|`c5?TI2sT!Dwqp4Qn4(0`EdC*lMv){xERkH=B?CfdqhOSwN{fF0ET{2$-N7^A( zOr`KTGraM7G>_|hu|igvy9pZ}kHaAWqeE7q>pPhfLJNK?yF=E6*ehInqt!2y$1zYn z#Q?Rbn8^AYt-MU$;nS%oTw@~V(cpLBoQ{Q`LZW>)TIagHk?A*CHT@|A&4xA5={-yj zsK>@Y>)QfmUY4vs!2>6#%8$f$(72vC`_TzJf}NA0@#b z6MQ3d-{KHN0d$>p&W$!_RbQl`s+dL_BJ(NLN@E62Rh%MgZ?meq(>!YcR)uE3ev$~# zQT|5(U6+R>^>%BNM=3U3bGsFEK*G{=v?yB>&AO zuf{dCRsyhI9|83M=YH0i^;hD^lzZ@Q4+ph&QnJpf$yJx2QkQg70H#DGuU%*LYWp!t z&^lf%4fk53+U`UYO_M5FE$jbaRhNI_OoeDV4sEQ;r%qag!)J$b*yT*c>~NaH=T2IL z!`~0#5d6ZKD#9SjVRsxFO`Wz-2XG>z2B;@ii(RD$pu2-J&AEtY|6#ftc@2lW?l$$I z)UG9ix%WZ;h``5goW0rGxO&i8XuPc4bb!uDOP1hWu8NM>HK;}x_IYNf)7f32IScY+ z&}MAf`r?mRpMEJVf5f1Tp>aKK7haMn>oJXul&$Nn0cr@RWfaMdmvB1Lu=}hNRUB(x zENf52RQlL`*5m3t3C2+iRnqjLQ6_i%$*Koa>wY|UES&=OC~Pb5B~R=@R^Qi(KsBEI1#rU>F@rHrg8w)wme)pO+V8N)CUk zL1D^n0K`)6m48Nl@nz~XfIh)Itp0Jx!!QSD#xY+fJ5Hx#Tpr@s8jPdr>1P7SldBkg zgUyUiG4JB$#!%&XzF@YUykjJ}67>`NV-&igEMl7-XR}qJykf^?*?F1nNyJ(3DFRoF z6q`+OtDTlMtE)10U&|?~ew@Q}h8sYSM*BO4yXrxCIe6Vv*Z+i@kfPiq+ju&Q*_C}$teHhUn(sqniQ z*jy=_PD?CwWy*kutmWy=pje>LrXB*YzTl3buMn+AB0Cy8hEDoAHX1p~09p#wI0PUk zmPgsyy43)O&umq=TQxE0&mt79m%%thL zCR3(_F}}So!7!e0)XSEz)vv#kv0fLk>9qkl>5PvSECU|5{N)Ew7L#(6egzm0Fibhv zQKGbv|F1r|<#Fq1H-1%q{c*hM>M|wq39FZyOw(n+6IQ>;&cZmRMGM0G?2KiG~^5?HQtVccK^aQ~$t%TjN2w+&7DEpQ(J+Il{ zDI+aP(Ij=F5iFc^;`*X+8tT6S{1*eL`JO%yE+mr5E+or1LV+rrm9ocvjP zEiuEar7e}r2wQFYP&{WdBB+{!Rp%%?4A4!$%uJ8tp#F?bN)53UHUD8aTNaO^CQ0M> z*m&fmau$kYq}q$x*%dnh(PW@IUaB1*(a*pm=_k!j9#=n-+-Ow??*Vr+9eLxBPKbOH50l15ip+Z5AgA0cfr(rCUp7)XY?vx2!X6>>HR z<`9xC>0V>}hK@p3Lle+VbZxB?k#Ui*Nx<&1QH>{LkPi zC&}!cB(s&+G7)mkGgj|(zg;QafmciD87thGj94FMH)Y(p0MGWLXoaS1e%9(cj-ygG z!qot8j9vh)2I%yNTZCe`5}^dtOEJRuQ)O@@Nz|~X7Os=&yyRTv+Dcv z4wSA4pv}fBnx-`$7!T0IR66PXJnpJWP^4Doi?aNAtE|7XH)SC;1#tAHXen;QYXSL) z0pC>q8sDPi6$@hL)&jBpok_JlkRDrCveM%jpH`3``z^(IQ)>TWEq4{l?!Q>WGntY? z=&GykD!~`5ezNcd>$vnzs2eSp9GLq>+42JJ6h_MK7p#)>(nF~J7p=0>JI6*NH&m`h zM|L@a%%~+TCY!J9C-T+lJaQ+B7}4b?lExOHM=Tam9-B`(ykzw*>KYsEkT}xP(_gYG z$}4^%nX}XvW#dcMSo>x@xCc{7rc}Ia`HjEYwa5&Qec4*=a(6Rj<#tzrySpiAuUHG+ zdyG|0o-8?Fc+$d;y<(l_(lK3Mvu?$M>J4vU!M^=9>zH)vPU|!xVOf(^izLgM(7Gd~ z!|PaZ?U8=3<4GJXFGKMpom)Nb;R=8ip9rwRyrEHg zL!NA0lcq$I=0uNAEyR7TqWf*dPYolbZmSh?_b}zF1Fl{&^;UlC;ID3+68xU^2(;Av zp0(FKYoB_#F2@^lhxUSfhn6BupIN?>*sUr6_5cq^R75ub0x35LZ_JTS*DK~lyRY#6 z8`Eq0voik!YgGF+$l{D1^n<+jfpx4|3A^Pu`45*Yx+j3tS;*b+c=w)dINW2HG;Xt&c{oVAWzOHMJcGI;myt5(Ll{fs&IexjLu-o> z9qXm>BX?dAmj|pd)Bl9s{P0(6%zt1q(O+U(nT&+DTT|SXrey4}rsf=CEs%(o(T^52 zJd2fbj(pT1-e)`NrR3ao?vE^2TPh%GRZ_JT{cWW5{+qQGp7k-h9c$iR27GMIFHo0Y zSO#$5?gAtL9FlsO{MLkg@v-%Q+1qZYeF-x6_ePd$KxocVysTGzsvq3mjb0*+S z?nEzyxx8Q+mXQ!@`7lpO+KeGmSK1Y?3q$Yq7@y*YyfIZ~3 zwS>$$55ErnakrHrdv;lA>TGwGov6OoD)*d*6LbcBj-O9nk($q~N@F7!sPRyieQvF7 z%M}h=m@U>WR6ElrQ^$I|a@EB~nkz}B{2jkCj+9IPZq4sV`_(f&ZG=kX@Ik4@Na`2Z zc+D+5<>C2XV4#x~`S>!>P|%P~bqlsX^Rw-$WJe*+p=T7WxUI~8-N;klxGh1DGHDBl zS{veYvvKzjvoS5X>qX*)9J=6&0cSja%Vo)or^QzT+R~ZMu7#X2$IO)3Ut0Onxg{}8 z+TDz&Uw`?%mC^GeB%+d-m{q6GHjH%XgX&8!+PY)taH#y4lK019%jY4 z?Ek=aDaB1{|6%#<%iuq(yfbteR2wrBEJyc#R#?wDtSc+R5r@lsop-n$u7|JJo3z77 ziQoPMPnHa+*kkq1)Hzt1etwcHbN1lrlGAu2#yViG*WYmfDySQQx1?-8DwQ(S^T!3InwqgUg8C1HYKyUt;43Rz zZn?mdB9m9+P@36$tU?*R4oit=GTqs-uMtNm4m!r;4WIdyb*|fe9B#+Hv1Vd-+JJAZ zysmxhr`X-Vj@C_lgonK>oUrYs&A0!OMc-O|%Rk4HV;1e~6|}cY5YJ{}db%Xp@vT*6 z3`AN^rfntlJ8M8G?@MCWGPG!xL}f=76>64xwoX$xVTfKnlfnQE}~xq8cnTz2i8XsVgOr>~`$>R#m$ZOqE2a@yBt_1~s zCzv(4wR_XacGq50Ab@oltFuOU?0);ZV-FcQVGE?4r_$F=f~u{)DaNFo~Ji={j%{_} zPsx1^2LBtOF$Vq#;mz-pySmjsU|Ccvo5sIFXHcfO(wAHTHwiI?uv+`7g@IIk)!K-GfWz;0TnXOO+(|pr9NZ-@Lrzs3Q@j7X_ z!)pvv7El!+H7g1{#Bj~{}UVYs@L%Stu{^t4Rz>*o$}aEqAp!& zJIAGMMv>{Sv;xNqjo_YdJCoDY2;t?K%12-LrR^M*GMg3Q;opvPgAAO1luJ98?z9N|F4yXGsVn>7{XZWLD)^4th2CFR0(#%gXU#B znC^CK>2z)}kD9tgc&^7?)Y56Ih70x_bRS4oq_Fg{EuG#GRu?s-#tdu6KPn*edN95KI*SZ7kHWJ>aTtx zMh;!l$YBR&;4~lMls4$)p47@2-hDqNr1Z%=>@w6TqRf1?5zGd}~^}XC{O1S}(m0 zHy4<$^?1|;cyw>Xqu!%wz;Nw=X1$l*;H5Wu=}lO}W&Y6~&tn2S+1Cd3I@ZHEE`Y=C zB#3jo$2Zd2?H2;y&0hKhtUxe*qQ~Q;01r0YAdf8`&dC9sj*W2s;PE}BwfhtKp6aDf z!=$(k(x-bo&Is^eV++bT)5AF{fWrnI#5r5z$aCDiZJf^5Rxf$38)fo5kHfYA2X;w8 z4(EF~7yJs&g&teiz4Q>Uy~s;mtfgGyakwYIPAoOIJbCgZ*`N~f$c6Yd7C?y$=h`@<4+!k$&IM*@bd5U@+URQ|Ff6B+smKm z<>RD!oV#>>pS!($cHz{Hfj!bafETEg*Y&$a!}0IJH zhp{u?(Dy>zc4yz7)H#Xd)N`_XYpOFq{>6QRrl1faS=bp!%$a#7_lq=#7yJX#oNTq= zpW=?~=yXhFCTB?;?@A4Udy>Jz+9k015Q~FS92Q{g@ZwXOqP^me1`i)ed~@bRKeXS zls|$T*h3i1afmY*+c2+*rl7$uM$;_!NGGop9J9!QK?}aMlT+A|a|zsM822rfj#s5S zT~dOzqw8*Vx-&cu%uAd5+&9uuS*Y1`)a?B#)r1+Z?lPRtkv(u1Rt@C_R{|FzO-~}j z2M&U>2zgzxv!q;(?T(!^bOt zjkqc(i0BX`YED@yLLVpZUsD9xaf)QOo7JBF)77AMN z;UJD1>Fjh=ek$BYge768x(o*zU3R_QDE%zbhA(+~ z>bU84awz@IM#wu1vfC|74V}ZYoNj$iYJ^qWC|w?-ifAeqR7sO#&^>^rvkWv3x-3<7 zv9h^eXrjdK7|XjiVx1CWG8Wn0f5ANsQy9)p$jtPe3hqX_d$Q;r%;q(WFY8uhqeplQ z%$EG4(G8L(kgfnW8EuBP45X~Y-WX<-NJAc_WMlWGjP2nm!A_6a^hrOv#$>aTU^d%M zEPMBk9?nV9x);}F$w_JLdNIsk)o4b^qUW#OW7_tIWYQfIBK5^6FGy1Rd0 zC^gayX|qy1>X@)K#jC?b>%%3UY?V|6)(lH()~qeA4eLaBT|;q|j#k&y2U1nxs=B)R zisEXWSrx9U3*?s9hGEiLKi>lcP-+_L*EZA_tuL->@MHxcMfEjBb@jEC)#aMMThrU= z7*QrEtEpX69A`{r*P@!TIEu>ZdV&HrkD(#UD^j>Th)}$;E-qPG8cfzTL{FYii=Sm(@0+s48s?sENdBTUAp&Xkd^fIL4K?Ze4Ahnby{9 z2*>GAS6LmTN3tTAE~$w#M@dbjE-t^mIF202xa{Ia?28-mD{e&3^x!!8;mSA*ha>BP z+125=WK}qrSru3E^0>V6xIFC@aZX=SRa{qBS+*(2u)L(GE>drrJyPo$Doa+w;{u?P znucn4eVukL;GhGE#beD6@HLgyHD0g6RPm}ns;r@^su4&b6xCIYuPpJJ3aFIECH0jx zUJI-!M(s3I!wb=Ri`QtmmDP>fn7b#}>7?7yn&R5JisGswbbiG}b(KeZtl4hjtl>4J zU~BZ6V5}V>GGuU3b=YgHI*FdsD8byihLt86VH(ZHq?ttX2`1so!DMlDT+*0J3)&c; ztgEOjt1qewmwC3=NE%vOSzb{uTBv@+J-rX6Dk`c`&|4r96pK!%5hT7x(R9EH^fDUO z*n%jbHd>H9m_>qS)ubyc>+2fzTskAxe-R_b=g^^XhDS1Jcq9XcuSYUy_d|z9;tbF1 zfZ@q2V0a`0mPRUQcqE%KdVgYLaU4GE7ymiLnGv7;f<>o@*7pJ*0NFU0@z&bMpVI@sot1uzlwcOteSmL ztg3xbth#+rtf?8$k@bGH8yIFjrs{o=seT_4a{(XJ*bOf1=cMTthghn6X&`vw>~&nzdjV)gLUk_*3aqe4*W+b ztwg&K=9`$-6qR72RE-%^QB`G~=U^VFs5D$xQd_yU-q;otB~>+bVM7z+V+j1N+Fjn? z>Ey1%Ap)whss@Yz==|#|&6LeRV?4Ym7Fc=1kJgWaM9lMjP-9-2I>xLn9A3@R0gwYC z{0yY%(4jG`wU|X{Bp|pc`A&PcI}X%Xk4{0s3KAn#>?*zS&9KLur4jc428G2VXc=`S zn5$G(R(oSyRd{2hC|q4015}4MV8qxM2U}A*EUs>uW*untcx_N#RkP9?Kz(2xCe|2~ zi|UJ4R(axT!<pAPFEYVjon$m+{7U}W#0JY(&a50=IUU)3i_obSZtBNY?idI(DL`qg`o&?nwdt*8i zyt;@306U0W+ORf2SqqhM5uhPe#Yba0Rf7_5U{ATBxYircRff6*F<{*}(7tOMR#u^y zYr^#vW>kVpqBOy(tE@(8FlDN%EU!jopn^)P!oGLw)``lkF0Zf9x|FDkleoI|u+)4l z!iz)?5Sz4l>A>}i2Z_Hb@_=z&hzH{pl7BrE05;~?zPzZ(<&%5GOQH6jW56c$amtrf zviO0ECDh|uTsj3j5Tgz+_=@Voru(VeR96(Vvesn1qZln#@LY zU*6P%(Aw~tn)SxvRJyu&O(0!TQCjI$1<_&Nk_}$Hd+BhsH|_J%xbiL!Kme@|ui<=j zO>uQ3Kw4iJlv9gJuUW(HCxAi^DygY1tMojW5>WG{nDNxY7B#irn&QOG|Zv+;OjjQfKLS>85J*hUmRf=ja!` znYn@L@uvwGm$0x!QQf9BD{H*DyL%3Jw)FT{4tBb=dvPz8Wlq9Z6(1C0<$+crZ|Lqz z20NqWxOPRWMC3~>!XPjn4a7aTR5)K?%@Toe^&FCizq`dyXR}NnF(iNBh`i#ewH3vK zvT_Fx95}T9z~TJ|4(YS|%wbNgB`e+NaA#Or-|-D)W#QWV>iP;3#pK8xI>LEkw>-?5 zDdlK)@kl4LO|SkH;i|R0`>T@&^HN)No_ozmXGp8ug4*)@`SmsKOCz2BNy!DzsDg;y zZALjWtpz=nFYmd0`SKn;@XH_2BY$~ze*OUL%aLNVdw!4n{O$vKFF0b(#A)+-4ya$V zwr9@roE!~b-gCjEBj$9^H&_!km2ar5cK12sx-0w#_f9i8Yc}YoD|FY_u{-t3Q ztpD1YwORd|62Gn7HzWn7osC{pBdxy8s3xWgZo#NG@!q%%j#dXw!VVSpH!gu z5HYL&#EAv-3a8B~S~O|i{Asgi6&;#I;-1qLaaQlD(yacqu@l-DJYvLvhPv7Th=ezW zO9rg0tZt~Utg0JOy=HW?8SVpPolfIN^qT-*9(34YhfNzeXkaWcd*HxBV~K)+1Bb^F zO9l=+ES6Xb8aHE{)2)3kwStkoc5O*+ZAJ0gx|-5WyXTB^aNqui=}ynxQ)f8sWnyoP zRA}CA@l26_;p1e@Hu3UnAw#@q|xf^jw7f%u6MSE947EzbJOf9r9)Qs>k3R zKb@>+SFyk6cQZlenW$DQ7-OH}KD*eN zVSgpQal0*XhG)JeUQt-vVz_*E_>b~td5gS8=~#ptBB*B}ic!@8EOEJbIFRn-#rYX- zhD+roa=W}tUM_bsrM`%JG5%Ps7xFJ7f(kc_7D`Cs`{F$S;F7Re!H?o)mHQHoS9<&g zD+mv~caD$9iNE8RrB=IzIKsnX&f~bzY)s$IUBA?6oAiVDUhK!;!hP+Yv(!nC?329F z7Yt*>i}D}xdHE9fydXnZU+3*Q2J;*TSJrjly8amfc^bMNkaJ{p41SsymN(uDOSW=O4~hhnbU3A7vghJej+{=AF6K$8%8`w#m^!Q$auL| z{xg_?_}>9955U%lYOzbDr^=DY8!e}4yS=i^8CrCeJO;2$*!AD!X~H!~pRHgzjjtgi z)l)ns_XeQN6h=SzE-jX-*Oz0zXWk1>1ty%75Mv}dZpTrH~7a^q;LmXo8ajpr( z87)$u=49+GS;do>CGU~eE2!x{%-;8}ezSnmqaOBB59{%7cCc;oq~Ag!o#S|}%g?Pxg@pX573eb!QclVKzB7sZNljF_b2XW>5{ zFf7RqEyMsk+ciN<7X!sOyg)bzk2OV(5VLSEdI@V$q*w;p63prdQSUap1mTes_`^ypd z=H3hp&WFKWM~O47!^O#BG(Lj$2Yd{=P@VzTeoyScxZKB@CQlIqkvb0(xmDm z!0Hj8YW$sNKBgM@U^-N}4P&1k{qzUb$&?{EI$5&u9s%~2H5{??th|2vy5#j6Z*8!u z`V6wZ&mG)nZ?D6x^W`=2P>X-xxdZ#(m78TsdjsNOW*q<M6`iI@|5#3ke#N#{_$SpTcOi7$fJ|`?~Dw z(#KBqW*jr2IwVE62*-{jTibJr6=0cNXm_!z`eY+j)n}#M1Lq$0;nvf{js-1ttfIgZ zmN=)|EW56d^P?M)>Td7Cn0&14WDNp$k`98B+jCOwdGNi{qd!{jM{gIuSfO0?y_X@K zFT*2z1Hq~=dW?Mv&UN-tAkRZ=xW(}kUmoKDU&=2-^_*?hqb%EVv??#!+55UIwUez`_T`9U z?8nZ}_n&MpB*zH4(`x&ApdM!z*`ut*b{OCn5;!-^hmg^#4eUnjS$a7( zD&^Wcu-%Nl2p{>x&iupjZbwWP1W%%ZdYAQ5-gWj%c{eGHm-2|m5V;IBuFDY0y+vih zoxF2ZpQGe+aK}E;t=8WGqqu!tK8NXFklSN8x@DZ+kL;eb-?Wd-+agzqrKsrz_EYj2 z;O(_fun&)3l<;D7ob`(RAt2Ae%BPb_;&1?2{?PPsrZ|3-z$*)1M%(h-?rtFm1ZcF0hYNX}Vpu{gRhA%Kl7kbZs4WM)!5u zo^ypAxstU2-#j1s9wnzh5e8GMI>q$9E*tGvkehEGi}CPk`yH^lFLz&;AFR*OQ+|cE zOxz3YJM4cc|4Fqsdcy23Va4?W`=02JfE{6fjpNfQ_n8Pz|3JN9SW76f6Jza{?Z1VW zI!X?Mx$^B+UixX-zHd^(%k~Qi&)T@&5-);>o-t|n>Vd|#ugkT9*3pk+>OZq!LFrew z+5be&2T*Fa9U%%H*-FrjNvF*5rMx9z#eUN`%&~H-Rj%0Y#8iGdTy1f5i1jwuZRwke zW2)UJ^Q7F5fbkeoKf)T}=yvQ>NZWK9uFH;+)1!l|7o%un5g7C+NzKrg$?YQ9dLdz7 zmn~rMy4^A1bGfbM6s1Bo%2@`SeO*|~$EiwVwPf4x+gs6{;Nw3i*{!k*uqi@^t_j@| zIwa6<(D@|%0)vQ`Jg)kDLO?Rr*BhhVkW`Y?z zKbMb2`(*aX+@6yKYLpJ;?3=LNe%JoSUWg*;X%v;&*X3#Hx0s(4|E;Q6>PuB*On-gV z{t@P5%Cua@Q=zji(|(-u;XL^XLm?0^6=!P2)VPn!!xjVv!}VH*2f9X$cpb*P*{3vS zAf0tD%!hy1_V7;e&U|uonD`O6d`qV~TRdRFubzy{mI?Us}? zOARMKt7MnlbHJENVzg5hxiC%;m0(yNa?hRO^d9nHTb(w?(aGkY1s=z9eDTJj5yprg zV;7^XTVI=<0vXp^2?T=75xHC$h!B1R{*LZG=G`5`sZXT# zPkXCfmrh&Lj%a^R`RE0c<3jf*#y5c6WHq{&Wlrm75&i#m;tgIuAE)@gw@ zKoHLug0NxHb_wkgxKQJVXZdVlAWRcqMK{98hhb+pE=v8nlTyOL&ru$l*5$4&pVGwgd;Am8-m2ZCw}-43;sk6_b(Yq3h_ckjs?;B3`gZCK z;;d{Xy2ImQCTP>Wl21y%E?S;9khev6-@ugdv&ruB?yOL4<5>EiZi$LKBc zy6E1Y|B!IXFPrVZVD*z9q<+ty?KSM%RXNYHHYTKs;n9xvlRtm;6IRR4Tp?iLQvY{Q0e)CtIU`e);E*`F~R;jJH3st%Ugr7vNfyu&?oS z^?_ejibV;h;xh3y1-m)AJK+EdzO}_kP-Y1By$NU9=hz?qvO<|-2OvkZ7?to0L_Z_L zKYt?|0I5dmE&Drplr;ui+D3avo#soQW_=h|RD+Djf z6R>{pf_&1tQ@mikgLQ-M_ATN8{I$R_a;-JbdPd$MT3g+4Wz$uZ*pVabdg~C`VEs*g zU|nL57LN*Pe~s0jyR8qz>DB=;z`oA9+ zTfS+%DTl~Ii{EV(0dOEU=!oHe;>4bHo~N zg#iAG{b%UcPJRs3byymC2BjK|tsPcW%H*Xo6PKme;6mw5>kM4RA0kf{A6kW0nS8*W zW_=6#DdIc%BWAw??dz?c_C?nBGDXg?58zk`RVUkPpxz_$Unu)&_G0@j(Ecnhuz!(} zbz&=Yz1I5Ft`tM%1nVuiP<{e0`&_<`Im}S`n*AKa^cOSjoiZdV#Rj<%XDa4^qMclA zUnnO*#Xno^t-Gwb)<5vwz%tw<$dw1|f5`8V<{EG%p0@s%{SIEnFO_rbqph%fA1kGY z+IL3e#a1u-eR-c8YMo+LipjV>|EH{xKidzAj@E}@vrhcWq9u0W6AO7(f9o@Qop=PQ zJ|o*o{7IC2Kt3qnlXuvo?IXn})<5lGvW>h&d;yVH$Xc;h9x9h$nfhIO6W&&f!t@`> z^KA(p!(}&EI?`3tinh@IX4KWE)-iT1R#!g2^~O4pXtlD^VW{_|v_C*yjTYnKHtX<~ z(cN~wJ>RMYWxWX7n?aF_+|l9~D_1@Su`8^35V6U6M2=AW)&X{m^}5woCW_asepvk+ zD&G`T^z(?^tRgSVE1>CHa;i1OIur}h)8z+p9+*n|MX2(s{W0PnL0~^S-OjMf-~%n~ zV{rUHCfYNtBdi;&Pq5m5r2VukvX8V*w$FjuqaijCF8vv}YzMC1j z)W{XGhgBz^LiYRO3;Q-)I38lvi#MpriM{w#t zimUBI>{}v&;P-*R=JC3GPS&Bk+-9re4toP?uFP(0y(?dof3&~F6!;!?w%l5eLzt!4><(f462eHwXR%>97v_^r;I{cmHyRxet65q(- zGV+l913<}mFXK_`czGNM54Y~JheMTHu$1(=Y>z+B>upQme1jF8CqeQIa))DG?sb_Y z_o3H*RsO*~PJU_qReS_^dt7GKixHM3dx+QMXbaA4Un6^Cq54_-D!Z$Fyj+E*d<)!f zo#^qh4hwYD` zScACJ`UbI&P<6xQJTVW)>t&8TU)(5<6}z$W@tpmZ+y}*;!~LvzqLaPN9%ApsD_hgV z8}e>B6pBWAi*@!?u&8SJ*5YC~<|uo!eGhH~trI!8mvam5w~$dkWvzEa zgQ|p)a+LflZhk!^Q>;@llpind2J;;GFm8^$DEf;N?ZdD%J4QB$d$5ql?PWl37Jn7@ z%68V$2uj-^{vtQoJpex2dKE~2v3iSb*7?>2)@*U1<>J^M*JZ`_bMgw5XPOuf-&kqi zZ#CH0+E-bxf@Oaw^&EWXC*VG2&qn?&;&!`-H3R7qt|j8EgRD)}dS zg!qeflJ#f%EUTk^0$l3@ln+^! zg7LqLw$Tt);562a_IWboDv?j<)tT*IY_)AWzL($pt zQfrP_h9#G8kv<-Ck=qcfKs@ptgnf@nAgjyJl~m#$=K*BAkNq&*U#rE^-*IxiI2JoM zkOTiPSmJ<;;JjX(Coac*!_)A`oOc1|F~s*`e^&N{Mdye&aqfl~k3CTl@5)bcX6j2G zBe<)+Uw(yp{!xA{_X15flAqLhH0mzd%9H3-aU(oIER`WE-x_E=B?npg5H{GFWX-aM zSuOPD^^_-qTdlRusl*7y2)hwY^Jd`OgmLdr)=6@UJQ??iPLZd|)8y&$ z40)zJOP(#y!Tqmu<#}?OJRkSui=`{?u*nhR3uwS;HvL6L%Kdh;}XMce8#ka7KG77>PL|3`r{t5A}Xv;s~mQ7bc62YPt z=i8)XEfN&o4->d+WEuw6>41W zxyZT=;5;Dhkl*31ziuSYtMkY9<5&{jZMCqUfC5|WrE&r+wN%cwo`+pFh|c!8_C9+Y z;O|&aO}13WkF1?oh`LQ4YbRMtfz6Fo{Sj_F)WUXML3zL2Dlq;pmA9a-ORbNsR5gjX z-5M+>TJPB3+E>~QVi}gk^5w<$XHah`%3q9S^R~E}Xb>GBk{1f6TI+FKDyQJ4i*6(M zNFg>ImdekOr!jH60Jk3q*A%r}xn`UhKVl{Iqr%G zZjYLK?56nS%wR)XW7(-nZ=E93JWpPK&#=TEWDmBPM^T0+`A~C~bteHw7DmZWQ{gF$mw|DQsMb`B-#9P;W;vLTzw2 z8pn2C7QZs235rpJWYbQOX+q}EA}oo{BV2Pq1VJmrqpp7iR0m>eF2a3xkCWnlvU z>Kr4$V8*9^u&%&$DO(q5ezf>-$vf&3VMbA$vGjoOvv(zr)g#2%y!?O#7ChJ!(amX( zG#hLC*ETX}oKF}liEzdn=lf|tPvfJz)tP?A9(W63Z^bcUzG3a->R5AW;%b`L@w^Z> z1{3$s5kIPt;?tVUkeYL29G&*rYdn)SXP^HYzA6!=nXjFXtYgik$)50cyp1UnKiIh` z2C3NHD^f-eM*2=5PvaR}b0(#Z|0{s2VVc6^`jdY)bo^r?a^Fy!IWu*@-Fl)k!#!t-){k5R0j(lM=y zhBue*kaf8*#CstTsPpat%C~Rs`PR1rd2c zMS}>2NV5x~Q;^Rrn&lY0}q~kY(j&ygLJXE>!PNEMrXfgOc&bz47N6>rx_eJW%N%{0 z^NO2#x>Jfz7HvG;X>dP5++BDEvK~7FSv$^DS=L#|YBpbcv;3lHmaFN5C zp6-r|oZcx|{#W|yBU0{b7dhQ>1y->AjTnCFVN*by-Rz5a?AkA&~}Vh8k*_;?9tP$vDqCpGO_jxWv(T52^oZ(MQ1C5!;>NeM$N^Qsb!4tratq z(#&~u-R(|Rh8Cr1G`=Fn!F_hS)2Wr==I-B)`^|tRUFP&&Y;bsfOeG$}`4JDCiFIH? zGnHf>bofUic|7`5NlFvk z16R~M6O%{o4Ep>i&uq>Z`<3<87jdKj*RJeUllk|~exG_|>^A0DsC`l4WAN5(+W)fDQ znf5nw&?$ZPIqDpfzc-cv?AYT8EhENDg8U7t$unsq!ALi7trMP2f+psu&${lOMh*jy zjGGi6`MnVx*6F1pqkj?sWQhk5K`{ z@Hn=oVnC!6tDdHwe54qTM+iAJS2(#TdsSK=aq$cWH(lWrg!aYo_lmt*y|bQhTD8@d z2F%NM^R9H}Q0e2Ybh^eBRTuCMafkX}3XP7G=Jn#0&f&4L5R>~;ful;fBmNjyWL?mw zfOvr?o@h_$A{#6CNHLt4h1`e!h$8P(X??_VNaCpruZk0+%f1gecg9#CrNs0zhVhYN zI3S1*?zXF(Lus77R|SS$JP@eRo{SmhQ8*S-x*R&QDH3T+o;&+$l;Z-G)<*%8Jn5c! zwbQ?kuYZnq}cJhEoycDx4i?o_1u$p41Fz+G^SGr$`k2e_wS<8;I5 z!f=XoZ@tD@6yd|WcOw0$yc0V&ol-~&u46jSKzY^>8paQP%EZc$PfU%Ig0sG~XBtm= zM*`Uz$sl)BB!uxbAOF&x`58)4jcHixg|l*%(+@WcDPRjyThyjgJTh!ixjaXht%3Te z(Hp}IMi5TSQx$EKQUPlCY6_Fmg(A!=l%B>8Q0N(+uFTeC10YwgUy#8mYClDt2cQB6 z2A_&XmD&Kv{N7(R9wc*Kop78;e=0|JYi%tIY{s6H{7Qiv`M*_bLK#dMqb z8J=k7mZ`lA_q`m^=X8mbBVLYY^?5E+M=h+} zJ z$g^fgEXGrCj%y=I0&}zqS`JeYT>)fhDu7^(kfAiy+OoF8k{c@^tV%#E!u6SXjN?6G zb=KGhrgQw17t_w`lQ!253{m`9D^3^{Z)i!<2zfg+j#Cbeq9*v*bn`eKwf>d4|s9kw8tv6a$%U z#;!MA;Vbbz&q~F1CEyxMJ3^_u^(MShdhSh5r;dbcC}WH>Rlq^9V*;b@%QrbAV0_j@ z5#Hg|Xn3bd#a4O{p8Z^dV_>>+cr^4nW-6^Q<@cygy^#}WmMV^hxCohAM3A8mA)Xc; z#MJq??W<^cR0^r#xG$rW*b)yH>Cj3fsjr7>QAXer>E5`@>22+iZptpFr~Az=CnMAg z6umvN99ph@A3k5e;7<$s;-j4Xa7|z&jd^*dE1#}h zD#m#FEC-LJVmY?>U?7ylJneiuGo^D4Y;2%x2G`^2w*3=sRcJ&b!av`o2zew-r^X?r zV*mkum!z;KJQ2*f3r`1V3UeeTACn~f84r_?0u|TQyPBC#;8{1l1%+saLX1Zq$ryAs z^2l7B^5KL&2IyUKqM~>Vl*E~@j#^-Z05W_AsMGN@1IZ`ypaP*rTc5qo3#RAGNgjo{ z^Epp(VoHlMaH8SmGC;@38Df4!p%IyPYfXJ?B*T%p%o!7xKiSJ>y^fK(c8ySG5n|F~ zWvUk^ALfkpC?Z;(dKGwj5mo0DD3b9?mGOWvj8k{ENv9$C3aaB2&g6L1`gm-t`vMQ9b0&hL z;S^y)QLDp5_`pO(qJ4nEHR^QaPn3D^jqx5uf$XKkGiN%siDD9VO-G>=-XC!M!5w)j z{#q@gHgY0(`gamG6SQ!qW`I<~!4zsyymn2FuQRaWi`&>KTn8;e!zX!AtyZ>DD-~#y z@vl9TJvvfFC?XXbyZ;%n3_g_H7vf36-1wjd_(t%_N+I$Xs<;gGNVE@-gNA68Q}GV6 z3atNBMKaVQ#5;|E4a8=I8&)JBoD>YkyH!H{QJ=;%@PSIC_6>?3s3^3nlM8bq`5qxj zeL|fb6s*;vsJsBC{v>j~q9mMQo+RU5Do!E&6-Ay$HxFLJ++Kh~Hp`zE6HJ<3iUhAc zU~3$-2m|k>SQ?zXm`Fmjc!NpdTzk=J3Qt6w+#ug9%Jd3M0krUJ_&_!`Gc_>m^uIEa zjyZi|`AC3*JC7-{k9W0A%yD?OQ0Mv*0gia$jR=6$)pj4ng2FSvhJh?~pjy0=I3LRm z6t3qf7b27M6bkPnT!ZYLHT6X*6~d=34#D?^aO*&%UaUa+S%ypS)sF3WW%6>j--GyG z=niBRicCCV*bT9r;tGZ8&vux+5>MA&<-yJAY7-IHc&6E=ik>I7p+ne)hsE$_8k|I* z{bP(wMYgp98WFc~ZlXS`(k4P;!$9TXp*~Gk;lT;jyE)>uB_(p1$FBl3hKIq`81b~* zfM?)ZhHyhmog{wXrR4%GH+VGDMO_W8Jrca)5YUmjaOY#b!D`S@ckeEzpPHynq5sAv zsxemlK8>FB=IS}AXI~+6Qo>>giohu3{UBXG;gtflTQ@`fpq4)5d|~ z*^Cx&%5(=r$d4zUKs%X` z<3(utGZ8;WnO*~bGsnW_IDRNU^a}6CeubkTmfnnRAL@C#0h(;X7XJ(wBVbIE8SEGn z56&mc3A-6*9V5Mu#dt7HEVc2Li4GrWeKcI)0eQ2<5Il&^^N1A8U@%9=jj!J#*{>N~ zgGbIjE@QC<{?Y?Dj_?Y_|(Vq7vs&BJQ zf)-)))1^x5u&jzLEJmmuz1Li6)*z;PWq2=!A%w|bVZ>rp3J}$5R2~ny(P*(u zQ!L-BW@sw5;@^waq&Psj~R-@pk z%gSUk727UWR^G)_W#u(+=Ot$XUmGOoJLD4c9VQTdm4A#qF=OnzxdZ;@w4D9la()*o z>q=rwz0%oj;k$V99j^jXUfdwXv@s|?)C4TzF{V?D>%g2>6qIQd)4fZg`mmKodL@9O z84+$+8VIq-K(k@o=Ml^y260j#+Fu0LQ#YN5BPRig5ucsTU^+b}hO@tn01Lg2PjBYL zjoq0k@4J$#u`KIrjh2yF?HNkxm}o>u2Ohn>jCZB3cfKpzNu=XnRQRSa*-_YRckSPt z&U5wie>niWf!(w(L=oOpN8SCsg}8C6=GYR|XPX>g>yCTK={VqETuA3D7th5ldfaI# zo9Ts#)<59Y@eG)IqWS|c#u)yF`?Oq#)3GNMj75F|w_=~fc^`H^MyGsA;aqL?RWVHN z@p761@$j^G1|Lt+Z$SC6Shg4WM-0FiU$fAGF)GCHlKQqC71A-S#w*^<&{q`>53h=d z)+h!+#3)2&z8bo88ZTHTd=(@{OkTc11RGvd!{_yyH-G>^_kyp+G}p|GFfxl5My9$< zM)7ZB%(Spq#ckMpVg6%bcs?7OA1KS~g$a(=+#pgI$@Jz=U&-b|7|?{*t*_tnI^97}zxQtB4d^k~Di}wf%@v$}vsm5p7+Tl{=Y~*gmaQ8OO0`LE} z$0tg7F_|JeVZlB{b`s3E*!K10kDN6-X7D_1kGRd|bg6KeRcqE7V0pdf&C zs+}tm$yVgcqj6g=Qyzzh;|GKNSg7_I1SHBriEoABT_F5r9M;MT@fo=kxz*l`{B3ye zAQ8&mXcq!5WJG}dLXf85t+&;P{mr@&L{ZUKUL^|UdlrcY%Gvf{xeKhzu(O z8^a6aQ+6U=WaE2HEZs^h-0{}kn^3zQ9whiPI2|t*$~r3@+<&%S!3x?!InbIT2V2+3 zzazdp0y44Am6j!#+!~IIZVEZm#zh38S)D-D#ZC~eE$(IZNY9I zi4I8f+eC|C%qY}560hL@8LOfTWGU2m7D}Z;$fw}2SRN2R;B#E*c=2=Q-HUSpP0l}j@Ps%;ib$au+sw6 zXp)>F9au9R=X80JeT{WJXa}G&en7d?v2Mx%I0bJN9u671Bl2bIRQnBxy~irRyPL&$ zbBXo5ShmEGvu}Kp3XB)v#p4=47eg=wJtrf0?RYUvdo+x_8YzF5XS3)*AEB4n|p&<7`kWTO*R2%1XLMsl$A{?IN=Gl13bLv z4ZK`=w{;nsU4gYkUSSPKUAI$KjBi*5(t}MPoi(*iv|T?IRk2y${u)An6)b8AFP(R zIk^y@;yc==70}mGRRvRcr?K9<{toxx@vi-O<49)CGyxF@9z1~;|cjR!C`+nJ5o<9rFF>V6RsS;4<`jC);d_ z@7U!a)QxbU93%%LHw@uV*lVD~7`egD#a98w$m6gtMGh4c@&-T@5P=D5dueiYD76?5n2idrm?8)MC2u5&&AHh___T>1YbCr z1(t8wi(t@Vbc-A~GvEVbJRjgfF?(|dqQlU>PWea(jyVHk!_g>(vD9YJC16j2pe3k6 z_Li(jF7Qo+=MMpgG4O$M9LLHv7`SUN<3obiEDO+RMx%_2L4Fm+tuR=jS=x#6Gm!xJ z3^3g#zzPFTiqd{HaPYMg;L}ovi&T_q3>3FL#Y^E8ZP2Xu0;@gp>M%@=!KlZoTmr>y zd}C%z1fw3iSo%N+A`|4>XmE*OngPV+N>Ce_3>GQSJQdKd5L*n!8J_1aR-R9$oE4ZC zw{ejTz9I0j(fjQ}Su-%;gk@h;D4TeHz^B6sD_Dw!N)*v2;=$h@)iuY?iD0}Kl@^jCQ9@2#MxlX*0S_Ukz{-HyIj~X&d;pKUKlQxR6>qD&sOO28 z1-1oV2UPWBr~uo8G9=%}3~7~R<7>>E^M!G2iM`I^-8jy-I9ah#XifksWCWkGVZZI5 zrM3fp9`f3Xd=&6-;D*389WnY}NNuAcD5(RIi4fKvOmcxj)>Dve0r?|^%mReuT;Or* zfc(X933k*WjJOj43&ACd(a8y-02b=?h0WdTvu?s z%K$q*db12ZQ6{oIFBt^&@EMWekjWb!jrekU*h9EJmS7`$_o z!bf9|pcaX4LIIG{0ilaTqj@SXAIJIFM`P!hx!+of8B#Qgj$P#+Kzs&b7-4X{AE_w{ z9*sV16+&@SBy9sqnuQ^g%0{Cr%VB;-R>OUGW>}(PED=AoWr8MP>3jt>Ev>Ox(GZsf zBCQE-zobwn_ws~L%Sa&%wnQ22e$)sNSEv-V&-RRYHT2h^+P=}c3EG>I8#qgj&tm`| z{Uyd(4WD4|MeI~Srz%c`NSTsrHKP%agI^Ly?zC5X46gPRAkvL?I$T9pLNuyfCFm(s z-Ppz`PEYaeK`u`zj?d!gp!r3$d=AIV9Ao37EC8mXJ2Qf)`G?r)DlB)7veABpPa5rF z+7am~!JxgvhxoOvy#qP@RW833vB+Z?G*UFW3i|WA^EMhtsdQJo>QqFc(NXBJ^lT#< zCoBx`#zLb*asJbML?esfI8u*%1U-G{o z$(_9)x0Mfn&8awOxzPI`r2c?s@%JEcja`vEG~W>3~$t@Rm^9jZO$hM)qMhEexJ+~TGg9hJ6+usZ#j$q7sWmBg>$&O z>wTxoc+<$J%)yEnjk4R*7(B*z9PZYvP=^rVdP0CgxiDeF=>LkfJE&VIy-gff-&8H# zzrE|s`@M8;R!Yo5ze6$p7mf3Ks{Oxhm-Nq^hX46G{qW=8&+89vq2E(VQ})+6s9jsb^TMzx~0<>xz5Ta3iA=3PS zfQGy{HmqtQf3Ef0%kyu=v8!IMpPw-xSxQC!y7&ItF!ubiwV2BmqL za}Z-Tp5sS5lXKAeqd_xWh@9+x`Hj=kePF-iG$|{&{LXT{(eeK!f@7A}uIe{MV?TYZ zc0^!S@q1XhrJL`BS{~HgzoT&9++%QS(%t!~)2SJ;T&3bAWP&PZB9@?%a0y8@xcJI* zQ}4DZ1FUu^zM01gAYVZHMD(Cqn zZ_dimsBuJCnF|-~k8IBOj3Ma?@xf;wGb|7eYFBsccTR!!ytW6N9xL=h8d(NC&xrW1 z#YuP9PtLgiU!G^s|KFb45C?V7|3~~~d`oJ@N8($By8f@Ui1F?vGSu_`wkUrUn~MLs zF}u3!WvH!N{hia2qwm==)YZ*8fZ5g!$)PsCV_(Aoj>C??u*2oz1pMpqxox%d<?eiHK!SGf#^FjMl;V+xOAJ*_6EQ=986zfPjojQVqB)GwSfrrQI21HB8mp(UiE6Aktp-&~^lk!`^KMiE zn67qDNC@?c>C_wdpbb994$cd-WXGGpwZ%-P9iY@to73FD3l3G;$X%{zdEZ2bQZ?hy z)y4HbLYqj707&oneZ>ujcj#LW6nZeTGH+2+yArIYr$J}*HE&{9V6VpG0NPHZMZ?^h z5K7ZlJ_^0iK^g~fO+E9L7gPTu`ryNKzCviS=sVCgCx+4@PGE_E;u*A?rsEkOeb=g) z`%LN`@owB@sYh(M25ApI1t-;|9R>o;v(ymss)xL#@vb$-4hafa+Ydish z&ZFt_{VmC%-f9f$9O~)b(lgYu`&c;+h`fKO>w@=>aEDLvC$rf~Mjtb?JrY?uti*>( z*oPXatMK?Mq^diA>cZCjSL;xQ`%H4EZ(~V#jT&s4m6V#J{qf(+xuQoX)4eM>#J@sx z&o<@B{+pcbED3p!<7wiuYp%AZNw058B7V5NctTMuQ9Q6hB z6wfHU=St(yYv!r}IKDo4^`{HA0{yeO=gMI+T~@kpghH7m@t1xa!##6*Cwv-H|HiEhFOt&fJU?;edrtd^?@7)1C`-WWSM3LhDn)j5Djf<@0y>4hx(+^l5ag_J zh4OiFGXc+9Gpf9${c8I8*w{lRrcWTkbSy&fjQ@X)QTw`4zSfO6MmIjR)eb$7EfDkk$^RTrUyaaTJ&nu`%$%Ei0@Z@8eb`5^LaAuUq&f9MLV|YZmMn zCu+=`md3=*fUHZeeU!HGTXIWOiPqmJsavwR}io6NMnEVKnyz z`;g&iL3)Z#HS~N=tA21r$%hXIO;SyYYAjX0L&yRngr3JKIv;Z)ik?%n0vYENgp}eh z1r4@7>#}AjXeJ(w?uO^KyCdaJ?ik81Hn)eUqx zbGDNJ9b2jaCrPeypX(Spve>w1g7<_G1#wnD22(sn?bNJ5kCSuZ85!#OPe02PjnX@^ zW3vK0`lqO949=q~T}*R2hvKft-4{EBGW*U47p*4VzEND3t2Q1qMHo5dc%n8r)K5*p zmIZCWDl@jwV*n<59!oMd^SUK^UgxRE95eG{oM9COy9Jq{j_w2Lq1?u^J?*4TM7g1i zQ0LA^#_BbmYX&SlAtN+;xvog#ZSfVU#q+2u(x|N6Mpq>5YbuhMv~Rj{Hn>WgE}=0^ z)g_uymvM&K?z%2YU7gfM;8KD~uc86QDrSX2Gc&&lGmnb;@~O5YWn#_g$QVZ&X|QD_%x?RR$6+gNmNz@nN` zzsf?pjK^cA6V)Zq6t6KJjFJ-A!9nI+bV4+i(JV-+(R^d+G{qjYGN6Y0W{*%-YOp}O z!=?(Pdfsd{Poq0o2K|R=n&yojq3&@!m=WXAD?O+Hvtr)xKSRkoSb2J!qO{+nfBFEQ zKs&vuTr!w~HP4pb$j>w|^mSBoC7U0sPqwC|@noj}k7#3(ow?^6Vy zCiW|kf=%Fr0z5cDU|8zzf7wYbBv*1LA9B~3JhB7UDaz5~9OdYm)j4_)H8mV)weEx2 zp^o`l@!!hYt?n60o7=Pl&`pB^hvDCJ{m$m!sjXFPrVnFA*lTf&$Fn7bD)X!ZXIR=A zjA;XM)Nh45{G4H>VE1FRMuwv9gtp2U20T~x3JsWT#$~eQGuD33%NUt6M?Z>5G3KF6 zGGFZ7Y1bFt#9Qtj*DKW7UEVvC6`=|Y`ZWs1DA?yuNVbPVu6<%JDVZ4&F&LJ|^w7MF zzmQk3kQ!TSn9<2&?K9KDmb=S(hjRMx~y+RpB_+=awo9a-WUmk7Xpbn;VRKYJD ztt5MgI!+j+iWOfNP0qUW8O`?Uju0cnlqDr6)V;(Y`<4#YWM*JA_3Mw!f{)iSO-t+Z zaJ- zz9O7eTU=cp&Z;TPstvEL4cCRM>x)-bg|i@oBz4TG-?TQI)vM0U=ok7jQoD0!uQkQ> zB^C8MclKTruCJ&mZD0(is_>?rJ9E}FC=N&O+?ib+-f#@^YF4fam((A-b7zm5vg3B{ z>{+umTzx!KwGrU2t*u;NTptz%AgB$Oh$%SNRhEmHpscH}Z78W1vp@u0@j;-Sb9VNq zuMu+zsBH*~c|fkO-6ZA{05!z|0M-{*iACVNzOuHy0r5g)ZXo$$=)R$%vMMZ=5L8)T zfv?-X+&?t$5d0HBKYq3tAHoy6qkneS$}%Y66Z0ipa!L$UZ!fPal`AtvB8vVQoE z!lC%{+KFO}7>jqRdKBRk;D8ipIpM=uHhx5ew?#RKRO-U2*Ww{>s>O{zW zc4lZ;q@&2f3$+<2`yzbJxdlo*24x*53dCeF5;j;U7Kr)yw$nU()}aDiPe$%=h0VY0 zZM;RJ%fuE)Uycu2G~E^o{DZsLD$d2n^A5*XM_`NAg5_7iO_>uKAg8)F3<)iir(HNS zl-FW|I1Of_p2@>Ktd=MT0dj@=7<|0HYZj6)KU{y4VBcDXOsUo0FW@?&#s6>msv6(~WBS zA(-E|$V{Km%;r-Mi{pPHz7!OxMZGzG}+u9BSYow^*{Q?9o_9CL%rHJQw#3%BSSM} z)$XiOq2iVWD@4<66~3R*c#Ah~AeWw%>3&iWaykah7sPmdRA~6_!^VeBmF}~X@D#>n zlS3WSO*wTf9gn}H_ck(2bssDUWu$0p#d5^)?*3(=0dCQ#P`eA4hkCfrEDbp-XVCptE57bnM3|V~_RGBg9wTl8OXkIxX;#peCDE1#VQ_dh z@iWo0H{A>^&bwcm61qxeFGf>35(8Kfjt%JfE=1vi;aqW^J7{WXliOu_XnE%e7%`^6 z8D@#Oq72(wbg+~0ue2@jja52CQXBNan_!Kl?rqaUsi~7;xD)ZI(5>QpdxjQvP=-HcG@HjtwvZ-gJlzvQ;2y3W885Ewa~`Cet=FOUWcH1tDyLf(wW+Do?3`3(qYgS_J|1;d6nfJouj? zJBkWE-1X^GkpH{)PA1dJvzp93_uO;OJ?GqW&p9&_V-#o8$qJRfPa@|hPr|Puwf|d% zllsb)RnYeu91{9o3C>Ob#|60x*jKKs!KdP=#r^!Jh7wb9lnupFMhb*g%KXV#UwIix zQJ$Pko>o2|My_S=V8nExbQn%d{r+UMFyk1`DrMYolCB(@LXK9-fT!S1{#b7cyG~)A znO{fyQt~U+AwNv48|Ky3|?o|>i{)fvQRY4|p_8`K;{Sh`ZsIHd=XWf*R@oC8!dJO%w4!gB}7Qz2%V`LSaa^0;Y zEqyV54~+hCx_A_rT}7ezX7o{!k4|Gqq$qA>bSWuTKAl4zE*y{c2poVT;^-B>jzQ@E zJH5@H^2}T^mheG**71xuwhSN7zxCIgDy6A+pV4bhB>EYJ((fpYKGqQBzcbu0+B!;C zt}IkB=izMDkD}uj0@m)2(>gRh?Yc7ENfkZKfE}B6p$4Ux6wcQb#aS4)n&GcT-$F)r zjGiPNK)d)qv8xzlH3+o%i!rC%X(wscyYXYl^iMx{wF=`sQDU*FC~g#gwetN`(ydpN z4E?@xMdzlq`An%-gWip(l8GMTT9TMT^C(5ACeJEO4zdc@=@NNW*;!2%^6QhIk=vh0;4n))jA=z*e(h#^T3j!Y>mp&4jFwZmB-4B#VTNEYJmYCRVui{r1!aQIwi zr^g}7!!2`eEE;WA>YK=QJt#PjfmxQV_Q}eFO=L!qnpEfU+!_hGlcE>#@iH=U(@2ZS z?66c(FiU@xqy?mZYw-f&ix*Orzb+&fh16DM5$T-J^MlgN0;kuF1;oi!;6Khk1MJ6n zlzmG`@#v3kYq7MHv{)^4Er}Oyju<)!Nrloni^*h)7}A84ho?piL`bPZPe&oe5r`N% z2`R5*>79ktdSzsoTsNo-9*`=D7`h5+%S+NTB8F~4O3tK+p}S!GusUMsAs8xv-cvBx z7DNoa1Vh0%<(@FtS@oCXdvr}^BT>}eq%iXZ`F2IjBx zHx3#-%@GLrn{wz>lzj9<&b3qxVmwX@h8jE)gGz>%!kLPWa$uA(OC!zg zJc`1o1*95t&{9S5%o<*eTk^Ol8e>Ao3DB?@2x=OYAmbq%WlIiK%R$aoE>>XoIlR)S zJbG2*ULd(f4WO4!k6*?$L-6_o5{I(+O~WjktBaup{$-gH z1~+J64baiZD1m7Weou3Bq0o<|YM>>bah}6kTrt@d+;m2;o(k1|m=@{ebW{|`6lpAo z(yx$ELXrYG=IZM-6;)nFATqFi~@`%2L&TPF3rB zE6K)$d6tqaKX@s)(F86z}HB@P!Fe2EEw#{u6u|jj9WE>2kkD;$#Bj5a(78Ecm?$Kq;%kzSkbX<*nD2P*5iv{_68hW{F-#HS zzXqvtAt9-$<+ivbEe*{rs5;GVK@7eyHJYe&vAfx27dy?=l;(ShFSSaDza6aJD#TAx zez=$98XSVKqqX0CS=kzT81i^T-raI`#dq$((681x(7>ji^}}w~;ZUBZmG$;*Ax?%xQIQRESx5 z*MuvaqA2uAE>qBNs&h0->`c3%Iut|;rs$;ASWmOk`~=Brb#Egx6S|qq497UvGKbM( zM`7#7Pm${q3}u4h2j!Q)lD^&W!=0xm71I5{`U}RwIR;usJVP!fgpG6PP+qVO)Hs~9 zQf)E0C??9;Ce(sMlALey`Gcl;AvwsVlM5^+tB);K^3sZT(Czn`ytKO-q6qjK-7d*h z0B<=*nrcu-Hq~5@?MZ9pY-;L|Fp3?t>_aiXK#E%DzCb!A z^vaYaPmS5>aDo7JHASOyaA3L2a%*S@Sz_p-*|T<`B({>d#?&$Yy5*+XgSPE$o!3gP z7m~leDPq9y`ei8hy-G~Euaxm>{Nol2{-qXSyomjkE*Sp#kqoUN(CR4;gNjVIC$I++-tz-0-?j=sT(X0;&PDCL9UD#ii8gKDJ_)p5TU~` z0Py3XqB8w8GNkKA2#Rp4{C$|4MM&C)FRQZcHIkoPDkRm=veLj|nQ>!_FPjj+8EtI48#`#MQ4&Ru9WQ~Bny zPb&Ki7-}Z1veB%J-$P7AFackX)6flwk<$Tb6cj&XiZWskxuN$4 z%cIszr@x_@eVB27#^E(HyH)PmLq;01@I$Z4JA26aq{6!C5re2i_L6>m^4L10`Pd;$bRXL;zCubiSrs8-cSq|1Ye2h-X<`NA@-bY5J zi;PZfK*BwjfQDwL~dhD$|-y~_ty{}?Ahd9&9koSmr$a)J`UJmRA#N0u)gEJ&wV>Ulu z?S&4Pi}ko29``~iu)(IRe~(-j7Lu{|;E8Xs<+yza5Zpo8+(hju%g5q6PS=zzSWWr3)kl}&rT`#pu;C+*ZOiBw9R=NGzLQxZr?kaNh482~V!*Lk zU6!rV4>QrACzHya?;un{g83$&jgdFtpi>ShKIm9I`pd%^c_*YYB7V`iufW#Q1 zb~%WEG*=UOA+Exz^qCF@YF&2FEQqzJ9(0`$MmFsP5`$7!7=auLrO0e7z2I<$jZq96 z-yE6?6|3`SQ*DEcrga7YW&tCjagwh!>D*d_Uc|aEERVWJl_z!y^jvm9QQ6@{Rhlh_ zxtT@`(}nnc6E*p%2O2er9IAe5AsLQ9t)>UAoT%tA9XD1#75RWzOU`h+9>*VTTOSb!K)FB*=oYKFO#0GPT;L;!9050|#lziGC1lo=8 zz^ADsR2hf;Dz}`Z$6q^0)RP27b-jEFd450@6CcpvM>4<%s4H^&^yBf6Nu9pi=~u+NOE9v`c)xN6)C44Kh^UPh-%m?vpQR}paWuy^&5L)v?Zf89#&JpD71LX9FXr3Ss zU>gencoFRy`%h)YY4^H){y?ndnCA~@bZbH$kKIc_oEeZ|ExU|rmQ&L3SbXKAX${{5 z$iM3Bw8&&<@hE4??b9~djofwY%fZ_*Jht-UxuQCU#|{tZu*-;UqGPlejZdcTB)%V2 z>*ae;+eo-TAcpP44U0G72lY+VjnrnCVPpU3yRm=tO&GJji5P~w-yRxGdJ>ru9~xib|IG2F-t9N$^9oi{WcHY+vhPz+x~> zUa_cDPmFsmuC6Gtuo7RNnq%ZHj+nEFL^X$lJ^DC)C+!S zc!*sudD^X$Jf)?RJeoSmqotQTnpcs$24#}xg2yT~uyXJ)e#t?T65!lH>mluwz;W6t z0kEhNG{tDN1{djJDzze>3o%~8bW$zV&~;Fv8eG#Z2&>tRp38RH<+Jlmqv;U9t0@;7 z0zGZC%O}(3rW$S!f|lEZpy~D?XuCZK3U3RlLfGd26ESF>uP??$)KA4Auz(S4cf>$3 zE8yYEru?*S9gG8-T6>^rj`&HKmyTxj_68Ro>qi6#`V29QEpcQD!<&o6*gBlYrWufX? z8?582SF>7u{G?)G(n4pLmOfPgRveW$tBA3LiCcn-5iJjL^{PPiG-`twtr7A~ts-jG zKJEh;v}>(hS1aV=Q)rP--JQ5=0CQu@;;KPeJjyU<)-Bs{+krn;&LKGDXsy;Blw@_= z$<4A|THw~TsFUQXrG3nusS7}pmfpj3fE<+hW}-*|$?I=aHy3Zyn~ypobuM=xh7R#M zn_O+$D1fK}205y8R5Kb?VE_W6LCH%`cdx@2RzprYQ_$^|V%*`0dY9izot8`0gGvqM zpBi^S~W1XscxUQSel(MJnH4ct`28Wa|X2}8kl$hi9v z@=E*+2}re&74kbO5f{&^xw@JpN4=ffAonl~prs?M1xavQjkX|yhSAMjbeuq)@tn$P$Vp5CUy1I^a%er+IJnWx*Jy*1H;uvmG98!eiB(DcwP^{#EI%EeS zzDyZ)oD?OgQ#2eW=2$?g#o<;RO)XM`(Q`PrL9L#k2jbQ<5AE6jqqT(+MpiZ9Xn~<5 ztb=NG20f})ZQwxd$We1afxyazIf%#3DVtu6>KbyWAi0)>^AhY z<@5c;`>1nZdghaG(^sq~$+hKNTN)Zi(2s35B_GT2X%{UJa%MOsW&KHVeG>N?$_pn+ z&rE(z<0zI7X|X2PsETCK>~YSyZlec_9u_@A zIE=d!-C4oGd=1*k!hwA6>C1j41FPM&kb!dX6v^+;%}-mGotH@%_v&@)fYYQ-NX;`s z5%35oShsFCLlWat2T}-*YCx2YpOVE&&(DYz@3GGQjGRc#ES*$7&6H`YuvIEU&*A6! zJm<)gYm6Bt`i(UiwQtph(Np9y_4y>g>7GK5D_-iAVYL0uQ# zyAp&?l%g-mU}e>Lk{`y)TTV|1_tjbaQ|R^Z`_Kh-qf?CkuvyC{NekePeWpgg+r?*q z7suO5^hS?M%1NO&+|_?5z#cTwuY42AW(%V&7RKkdL1i4HVpH#kp=t%3tDv@t6JtZ# zfdAJtdGv71ElyEhJWnRfW!jbn`FqAeqSsP+J~f=y|*(Ptg4f?*pakW&hY)At7fa9c`j zAW`bBMRbR?o#kuGDD_~p@i0Rli`_=;*;*nP|4!GGG1k|Ju|Y;Vi#^^UgPSsjJr1nV zxCN7U1M$+aAU}?k7(srA@(tE8rG`?;pTIXAtI%47#B@e(KopAmdH`lont3V=c`ZQ0 z>7sKc&Rex!N0`wP-S3!{=*=5RyJDF;|TZO~AYE_t`o^D-&O8%615 zmPtVe*tw4LQRbGNpwNqUnajBR6Z@AGfF}EYgM~N3v;h%GKwou*k>gRAvBV zNFjbb*Ai>e)ifz*E|Wg^P1Q@6Np?5|ddK3*1CmRs0ks-BWo~)YOIn45MmAp#KnU!q zo)hM>88HSBjEUP!$K+mSW6P@! zL@b7hHmeeEe>&?h|6VqKWwV#vNygZ3z$Gj=x3U>agRa53@DxSLsBD(4aTD3)G`1J| z0=0DPIPgDB4cmb`k#fuU9WV{4fb3CTxI&V{KT{_1IK;_JG5K~%Dwl(pB^tXj38^6D zv{oUxlp{r-eXD zln!g-UMeK9m97RhLNQ>92~CU!qZ-8BCaC5;N+D;4BjAJ414UR$No3AI4gn>6her9p zGWu??y~g48gaVT7Cd%5_$kc)EDX3wg(&okFfo7Y9NvJ}c;KRY_c2Vm`vf>NcY?z`F z5A*WjC6t9}xs&~fws8BzWuu093si%2kv;=vvr;>rK42_vWP>=(3vEhYp<|DH+gM=E zET{~^E!vS51`w?^*~U|PvkK^VRxLm-Y0Q`Ke*w6{onNi1FFv# zw@gpEyCyvPx%EAEp1S3}d*?Tyi=R{C*q>@X823ZhW9RyOx%gmOt@v5Qlo8h@X@!6KI#-v$ z{jWvWc--v5VI`*j(7V&w6E%yzJU{Jc`OW36SPFMf;@;&SzOf*o?~(_H-81^Gf3CR* zR;_X{NDW{7>H2};1ASjPylqR)@7@Ks$=^X{@G|0KPxedN|IfD{O|X{#?e2bKheFYm z2e!S$)7$&p^g(9N>isJwJaqBFM7({jorz-6AIC~YwoY0(%b0TanqQXT9r?U+DbR>e zt`XDC|MkwX#htS5n%QeyO5nTT258O}MjR)SPNsj|F>dKA4|IFDF!KIn2S`S}lxTGx zdTYeodtaHo?fa4oUG902ve+z(cYn~7Qqp?p+|gUyZ&od^euM>cKPMJ_yZ-*0f?vP% z(RI#uUiqlb)Y4L5LuCoR8d0djGi8eS>+|LFZr^F`yJ=KuAbeqc?lTbNlm>cA%i`ll zUU;SFf2cr0AO=fBf#wo#HrzrNvHG@%lbZtH;dS zSh8-;+AB+LwdR5yen5%RJTZREtv^{CZhuNXYJOt{);7tH`W$MOVuvrD3ro*7D21Ko zZH*jujAlD3di01Bv+w>gbJXC?uN-c=EBU9)NwZK`JfQ2 z#GI{o@mBkDz5bGVO@00Nzq>}fgdYN+0g2dY;D=)8x`v$}HxInDspB#HwgGedVdnS6 z$L;pA@;5F&Tse8-jJF0gJ&s=Os1}dyzW%?@$bUOMYmg`JrZ4Urg(Wc82hS)fcOJ9s zpB;MV4)-~ixaA`-84c~k`-H@IDqrmJ1-+=F6}yVZ>(}L^J$7(b@(pW_Z-kATt@J?@al4`Q!IPV$w~jcc4?VoWaw8dsf!tpO!YiDhm@`5Su zFP7!aEB-kj_Gq3!(^Ijmpy%lZcle{FP0f|BAG~-A?Vyp6c+)SV#_q4$QkxW#JwsEs z4xzh=ot8M8#PAKfH~!x3;JdfnTt0I9>&4rba(aV{!~x&v>B{ODs?f2PARXg_)~+DG$GS$A4$u^_x2mI%MIPm>s@jbN`1w z+V;lTCp+v)eQ6#TpA5rgzsezQeIu*kxx-J)oOrI!<5PdSrW|HArFxziT=MH1*&8>V z|Lm(HM-A%}z6NvbU=lyK6z2bOqTjZW$1lx}ztr_JItik@uz3902d}x}JTYUa@XV@? z?)9^wzA}D8UfgkZM8*d1!QIAlyT+f~`NiE-=PZ~K?|t#~`e&9qdcD6R@#DvSo7a&} zLxUdi#NNN_=^7JcIUGUV=dYCE`8Qwi~hm;P9L z-F@8)?@7&=ZhU0Kc!)_0gT(<)ymXtb#=SxM{b=HQQXmcEs21tgX&8FOv^)IsfEU02 zzw=L4jBNP=%d6y$`Q^`EU7IPbUF044>d^Gx#=vgdBtD|@)Njt48;4Er6~DxCdD0q~ z6h>ktwc;P|<_>tVWnliIwG*Fub>!l;)O6LzSp4){^`0k=`tST<_+{y(9Zdp8m4;dJ zB3@~_IJf^3#;x@Wwq0}cQwu(gT0Gbh^FOUQ{z~EP7ni5GKY9J{Ho{=@;NlfUMdrxUvzBHpqXC;CLP$|eEIRt3+Qxe$SKBeJUMYfux@|hQ^!-! zxtj1hE7>+rjmJ?di}zkRHQVy9*`qprGj_p)D#ULHoJi1U_{JSQ%! zd-|I3-@J05ddGC@Z#%&xPYK1^o%=2q{oV07-Ye#GL%DdBt zuXz8|wb$Z^h-DPwkawT^i$AWTd*<%T;VXMy{x4ieR(S)>m&7sOZ5vrvKKH#LcdYv7 zALlnUVw=*KS6u$_*1U`}E=2`_}jEaQur+SUAmqMd#O>O3N4hkscl-l3g9+uTdxql!Jg6 zKY9A`kB@c#{e{Ob-MBS{{ETI(*`_#pXm&%5`SXm_&DB4>KWpP2i)~8j*toQ}^J%p! z4*!%+np8=@X>}$pu1m1gI?WmPMl&FX%N~O~H2vKw+glN>E zr3Xz!A)mtFBA=pCh=x2D4WbZDo{CcQf4|S&XFB(k@8|pb{a*jWYM=GqYp=cb+H3E# z&$;`Y`D|wKcMtb?AX{yn8x*x%Dqm3rb9eSoi>w-zrxr`atYgU|HrIY>OiWBWkOAUx zIp{GEF$Lm5Ol%bktQD%jdR1kpC#)i)`xz^c<1PJ^#-d7}0Gl7tXq%Dw=m``pvnq}5 z?VmhB&eJDQ_pnuN2Gs{v$Q&zk_NWvYvD!?LUhRDe)_JkL;ey$*d8vz0FcZWUEwVzs zLJt!5jcQLBr}blTo&;(E8UgxWlvj(bKwLo0w~CSia_PHfhBYRxrCM*zjLTE+Su5g7 z)k#HbZ+Uz$eK}N*0y(BVZdKZOAI29z;&6OGEw}s$%b=wsF<^a?FwQ1ph#n)9jJNWWgK&n=|mopWnc`d;-&by<_W z%GU&7wpEtl5B-Ru$>0h>90S|Ivvm%?Rp-;_JP_mRTM%WbrMXT!A#Dt5r1?aoBq!V?8=X91cZWb+Jd_Tn}I3 z;k$YGPT*N_0f=b_oifnfhGc8GE+H*Yq|=i;f+!}|8JP%*) z;b(jJa5R5m3_ILi!8abh-opnFiEjC>9{#*)xv0j>tbqrHfRaI@L7b8{Sks2#5>mZ# zSgnD{weAPM_1N&moVhO>j(-Ds& zCne;UI#Ng-8t;&a&IB#uEc-r&aNizxvFHeGMb%vtI9(C2Oaf3D)vSIWlHwVn+4ONlW8ZtQER( z8vZ?eV_~8XMS1y*ld`RDCn6dTadT6jfwZ-C7u7 zU!9y{?S7-Bl{7s~lHS3JZ^ZK|!AiP5%{p`XKozvhu9}`A9ZpZou(nN~s6MJL39U1# z8{Ixbg)XU&T$*{A<+M#-8o(T$6VO*jBi94>NZo*uj4XRvPeAIF9RgWS^$y1J#lWbK zI6K{uefvoL$+oZqQuy8@(HEa{Jp2)>?2f`rs^CTX-oGQ&aY!Uf+3BWVrAqzygrKZi znv@`)oRO54$<+kAkYU7wGk)W0^Ujh)9lj&xoQ|_abE-5yq!O#k>UEX1%9?*oniy}W zi_)opmGGc~M%7*C#T)8otN6iynrIDuu(%axCWZ%F!AmQ{Ga1Bg9b>JA+*Q?E9xPJo z0qgKX0d=S4pI_YSR%E&hajZIpLRQ86fSPX2o&K zt|VaX{2{^G{%{7kx`&JLZ_$r=)_?`gFdVlmz=F}5wSX(`$obv{U2z^H(3bjE(pZWaN*FDn4 zQ2)02FBPlv(w6F(>i$ay$Ew$>s~+F1n!gNXoWnV&vp{SlHNR3FT0S<;=o>Es(-N~( zj?6Ai$P01lN_Y1IwE{7Gc+RPimt>xEI^?v)a}FUV?8rMSNY2^ho9TQ;8hO9wX$5&& z#PYNbe8`@O2{33VkO3m^7{zmvV;Bt~?-<9Fyknpf|HP<|dU(!QI$NK!4(6qDsmDxS z4hYaH^0bmXt!6;_rSbDBuX^gL*AuPI+fq`e17q}+f|8`Zxz8`Rm&IpvnhKr+dkCn9 zKDT8wR)myCq+Cg2qCdX^EGO)~AXd*M8ht^Yrf_`sm7>)O1J0`4Rv2OfIU?Ec-XI=q zB&j!u$H}0!AUcH&H$fMH=m7GxkvtccYzOTv)aPz{84)b&7=${k`zI$#i>DGZ(plj+ zkW=|Msn{IrmpQK`ru3n4juFgfg=`VenbNT&M~2}-!)Oc*OSbyIQfL{yGI;Tr?U$^l z5}Wzh^2XNeSA#Nrb8Lb%nu>{M>du4|d45T32K%LY-YW@lvh!PCGi%>(3DvKzo9G+# z8|-vvI_Rfgrnn(}6Uj82_%BQoa7|hvV4&*7^@`vi7~6P(9|O7h+}mJ1VX1evcJf zHP4!98RPQJqw@OciCLjv&^KJ3I9_3YoenS13O9D8$5VHJ_eRM=?LF4RLCCroakuII zc4jf=Yu){9f#*ER_jq^(1&%Q&8K;3$8tP=L`pfQWWA)xIEv}VAwdG)HYrEr;SMC40$ndR4;Z&*Fnc$ZtCncs>lXi8% zm9J`7Km5CA7gp-kv%j6qqW;}m!0g(ctkj#;b$k2@m%sQQDv={UbeC7>V|~G^MtLlI zNDF*`bSLQh>UF>EFqCC2I#8${l;EezZ|ywLQ9WcOA1t&s9muFY?_dTNW7Xw<4p-{t z>NS6vhLY-ahb!VT8BsI?YU()yl!M-sQbYAq^JKQ6N)v5&0c|Zs_h7&uFx2Uh#z}Wm zjfGT|sjxf>V*xY)p(pEnK-Y&0;#6a@-Q#gf)$L%0Oo~@a2kpRw?w)S11MiNKvEXTj z6D4PPujSbR1Hy zuL?k%aBxvcdo-zqb!lCiY9!oID;&k%^G+m9<(G(}4WL1>N z%2+`_iq@!rY)yv0ID?InrYU$LzfroUs6}dH_`?)cZ>S^kVPo~1Zvh12r2ZB&Ak(u| zLU>=A+K5qaKU58GYob!Xgln5BQ>g{AD??32-q1|78cBSXT7zUmma0?>1x;Ed4a%}%h z5Z5X6Bv<=O!oeVl9ScgCmZOT)Hd&d2x}TSt997-vF?8GxT!VLmVlc1!L3e|`2W4PN zosQ954XOu~$?9A+SXGJH8dlq$uV}@v<2=HCWX<*%K}yf(O8Jr4p#0ccO;k%|XrAh> z9+k>GHPn8Hz`mLW;+l#VUE2H@h&X8kXrnZ4qYBkBDQ=_6)#I`VoSfE1Wytn62!Vxd zRGN%fsuCnAUo~s)wuKSUV2c#ztDrp^;=|=QRceKV+QOVCCEOPM@s#u{P_xw2Qd6J; zYNf0zK?iRwP^W}XYp32-;m#e@!1&A!P|0bFQNuJc2Cb9S28^GYzA8_8by6*5{>kbi z*}dLKlT}@D_i$xbsM*?8Jz&c1-BnKFD3t65S|t^oR3Ln1cl8q<7lq4CQ;U+3?mbKS zjl?9llvCVZYuy(CX?u=prdCVIIjYR4e>?oZIqEc}o|P@_5^9)2Epce8H?Pdl9Q*MWCzqFXKp@2#UOf`#nc zD5qc_Ey%kZ2kWXaw=?rK=5}V5#@vR*YRqliuYX32;dm+Jluipj(O_#=#jj|Lw-$~u z^MScNa}RiTg}3N3ZCzz9)EFmGM^8JAwI1mLeE{9c|2!D6w1Z3L3t;Y$dB?-A_3*3Y z(`80pPkNv2V9F_qb}(A5fw;TM%RR*hN#zB~FKaJQ&!m??p5?hfU^-N$4ZtPkb6GRM zzP#m?ss5^mRFq)^oP>Njn9~Sl9iCC)=6R`b^SsErd1v)`4shyYUV={D7+u0VjfHH6 z4I@ayox>Ih4d{(?r;ap66*D=@IH1!KPO=V08B%u_#&Jlj z*o9?i>l&OrSQm2iv@Jk5o1w)bMr^AWckFVU3a+R!nY^ExrNfxNO4 zI~hc|5E&=l9FSNxh^gB%!4qIP8gskaF~E&+yi%VV%i}`L3${6dV7|uOUBZFOvTiSM z;CiukC&1b_VCY20S`JoH|*Zbk@~UgRGD{tBcNZF!zw}{Co76ZROz` zgLhAON3fDhf<9;N`3k&S-_}Tev2ErxT9A{&T3wLlyC;oh9tE?0lNpQ6Y?^p-pBXa`fHPS8LV%S_aTS<~d}19zT(&S^&IhrxXdE8c4@?Xua%52~ zB#nnEfBNN`E!XK~Qa4!ndrr_Sy-Dc`onEa|C*RA@l`ww7Z2zDZo90QUYkr1KZThlagV|-+YmVAJOSjCzay;$-$Gn*;P9GQJpT+=`A|F!CK@G%BEqy zGzB{*ntqu-(M*%wsj(B$^Q6N){0z8|XPW+ejtNeHFM>FjvO&BH>jR=f z@;<4YpbDDs@-hQNnDd_*Bae?zXZvDt9+0{b%HN*aC>CWBcvfhSBBZ&XELmBuf|>uJ zDjXDNMgNDI&P5TeY3V;|%IrlcP?Sy5cqH!R3Z(um<9Ii{1nGZpQy5wQvzt_w1g=Ee zF8aT)s6ZxNfm_&rFze-iHtUuDwOI-Or)Gt&{AWkK`p*`v`CnV~8YFof9|ZraIM^WQH^xuDw^}p&rb*-!%t%_a2oyp1I_&^F=g;D$8;+|FJvba=SrSjUY#c4Ot zI-S0blxwXV5XS)X-iVQ$&k;;puTp7=92|TAlP|UJC;4Ui$*~ESCxYi}!DZ=XpyNyf zHUbni?!eCgF$kK0IBnqBLcKGMOasr!`zM(&Mg>zFss&_-jKR~4^|E7(Dr~<2NP~-U zJ_N)Ta4OjdYRHqKu_~DUCLk(H0NGQcl#f-D(>EOl?;5L0GB zxBfYQ$vD+6^KIm(fY^H8QLse`vThviWPTloZJP5W{%ZTtRngUIaC6Rflr95t{-<`@ zI8PQ`t%{}XU$MBVU5ypZ-BN$G%ImWpd9y(D;U%C^Ag8%(`W>K7pbJ6FXFsvstb=jV zQmSrADU$i))#)l-rVUC7w4!TbK^;LqKfxH z94l_4+JcXlauuH^nRJ^zGZ~L{3T+T=fa~3h>RUC>nkd6T*V!YJRxdgK z!iaABd2-8C3eh2aTAw5<&+`Q?j)Q*s&$-WJFVI@13>;D~5R38PB84{e1bq(TWH2AZ zSjYi!ak@c@uT#U*H{z5n*$#>{e8qKm3cW#^PF7WTvQ<@?g6D0MRd4+8f$ckLhpb+L zhvQr4B-lTFm7~}y5S?U#cu+fs!Z;AEwq>m1nR&ACdUcEXLi{&iy7*Gc11bLSbvLN@ z6`0Z~DwKaMq$h$H^(@Jr$^}s)^Ehm;kv&szPt?EyVpA#3>g<~cw~JhNSv6I)QQz{sP>xQ8pT3luX=-pQ_8IG> zs~GQWgJbJPDY-=jG93~20i%Y^+b9*c;Gy*wvhEiA-0)p^@~vu_nYbG{H2Ae}@HSOs zWbVN^L#(T|CkL&VsXbwEIC%mOn z1q`%q&s;UZfZX1P@DswM2i5t_*)oO+yM7XguCtqDRdnnwNe`*h|5-%JA5yc`kJL6) z?Y7D~b(g90)kmSd&_Qpl1o2=f(qn5u7lT+IkJ~`x6F}WTEW?9gM)_AjQ$ZX@oFRDd zoOAAI5JS}|!@lGq3T37F!>WBIE7Ng_vxvfVviWQ?uN8IuV|`Nj9}MM2b5l||%QAWy zE~yfJSOqU()X+O@fun&T;RM>NIOjntiD!a_gLt^T@c(33t0=>u*|CUMjx4EKpaQuG zF4%1-yP2+fRcaUDCYQ4l?J5M(tN+0q%;q+d#tU)D|B0K?Wxzs}*5@hYuwNX>3E*i5 zc^;Q|_zOLJu~aQo#YsOylwDTjlOBszw%Qjq7xCApI*DJ5VYpw0E>^{vzd*tXL|&{I z3?EA6-&o77U99dyaQA;i6`lVpV0(H-%9iAS=yfj7*l}$^yb#kbY&d87&LB>IEO!ow zZDfuNhKJLNt8spdtXm!DKWigSIcw75n?W3sbQ=#=p9^xUam=Ap95<%O z>iERKsg8D9GZVyv=R9aBg2KLLGXz=f9iY>sbg3%vb;IdFnXpt9hS+WfE&GxN^aI6# zXoy>L0eBv4x1*7@vLPI)JnoJpc31G!vBF)(wgP#q14oMnr!rEV4q?UPq;4N3&b3we z1@BNoN{agPSP!bdq^=70HVhZHkqky2PQ{!$Y-6Qlxhj>lPvAA9vzMwiwgV2)0bT7E zTd0F&GC=h5JP;2$fxXol^45a%d?Q?)WwGQB`FBj_8w8oXV?@sucYz z`^-mGUcS=@EXWEOm4AciJ*Uz*+43l!vbpP^U!1T%;uW`Mx50}*kEtG=+(jVOppmhd z4`TnauUTuXlub(ZhyH)+(tqwzRNVx`)}X<1WFNM_9_!zuuKul;QB_!ttd9(?^PW)H zBh%1_cs)rPFINS9oDtxjF{VQ~XZ&ms+wRCP6plNW9gnGgiJOqc1*?+EU3gH$(q$kX zPKoh2zZJycN=@`)jFhZUdG;M4ixd;WVHc5t6_{E#gJqWE=t$NSWOZ_~ST7H!q6s+n zR%A-0Q_*p=i)>z@g1HPW#%U2~Du|T^K|CUrQtSdpjJM>D7^h7hjsfnLvZF?W=wD~d zvl@>1saE5g0}XRF zNtY_sIWnEcp`Ym(1H{8Sou5!2)^IMh z%dvZ4lO05owE~ZdDeCs86FKpA1E{;w_&MfL^4?wZ6%*H{bJ zruB3hOIQ6*6D1>^{&MCspU9J{*bclq05hAt84IG{95G%DI4yFnV-jBbBX-jh2^l0Y$xqTK8$51(V;y@5P-j?W8=9|7f03%0a>5 zp91Z4%jZ(IQuVj5D2-&o(`sz*#=8DAq;4(!JzBGPe+>qvixhcJ|O+m!CMsYo@E&`MQc^#9wMvHd*j8!ID+ZfUB`%kY@@2k!AD>lxK9 zBOX#*!#PzgWzK+S)b$~j=ip$P`kaPv zmUE(qULJ%p?l>p`?~a3C^oA2o`M?d_|E*gU>$k>SoF<#@^0kz$clpv<_d+hG0Uo?) zW`TNwf@m6Bu+X$d_RI<|d{*6L7&%Jb5Bgfj+G^ayW3li8_K9tj;uqAX;F`XOJLrw! z2`^&9TO>1>NNx5UCmUYEx?`i%zl7htHi|#2W}cCO%&{Q%?F_4Bm$Kn>#yKGJoWY02jg|DgdPE>9{fEDtJORqbXIyk+~R()jEof+`iXY%Q5YFVbcaDxzU#s{}z z78{TY;%bMhQ^$~x!u7acS1MORU%;Gh>r_jlwXz0gWXbq-s?ABmFeP==@)a)pD#FKxO=G}H}bXAz) zk^fsy!dhQx%(u}%%zGaGNe?d`e$Ww_F(~mR*>}2`(wtG;!ft3Jih0f`&I{MRp~l9h zw}Gp<3}R0{2O7iuq(QlH6JF}dM;<4HV|nYIO28AScd)N;Ojk1_+;%gf-Ds=k4>DWG zoKt`-e@k7Yi~?mndsbGs$vf(G)xI6H@P4m9h)YC{ZucdmJ@O+H>ftS_dt!$McHP=| z{04~IXQNQbR}aKyN1pcYdsmILFMd5_)_bZrmvd@w6k^&3DQAlk5D#K!O8I-LC{(IN z`s(y7ot~}JemXrzr{^MN!)dlNb)N?;8N7Sy_Jilt-Twr693sp+UttC7El58w^8ys) zd=jtu0h)JKo@L>FTk$AR4V2k6m_P=~ni^G@I|x$kPy&hV-GMmaxicbD@WYDohqK>T zIV$}^&CDRYq&e}*5cgHrJso(^AuHNd4QS?QEy zFHzFgWM``@rRFo`&mDza+a1VdQ*uBI5V~qK@=~qU2mI$^ ztDeo^S=6~*j#M~whw9&a62xd_1yaY`Y=5$p--~x_w(U>@)6YkKE{F$Zua&M}V0Szl zngx~(rFO1bSo6PleJjN;O&h*YVRfBM`%>Y(90~5kfZr%(JJqN}PR^r1t)(g_u|U4r zsd}7C>`G7$i2ctggtbjZHN2klN=w7-i5+Pkh&r6ro0E60jH*?IK3knwwW{ip>!HD! zUTEMA9{xrTKgGk}X%O=Zvo`=s^e|Wi9DEptAxH*f%emNNp=zsx{lc) z;JuOZAU{Kjzs4`QxBVBbx7%9NXS%eqeRs&puQ8tQR5G%s*;b~%n1~mfzrk-&>#bnN zfSmb_{lIPLH(bccY9zjmDAm#`FZG98?@}F=x=YHwRfWxGK{4IB0Azw%gUEkwRW$a8 zpZ-?et?=7<*WGHkx<@LR+#BAzTdg*m%tlFPCT4@~!;*5mnI-FgRL`pW!;|-_H3lj# z+NY)ag8-y=(wy|5SE|u6ZwRGZS!5iUhy8U#-lZqmASs;K4ya zW9f-XCB5HQt!3YS{L24;#Q%a<9p=hdB+chRoR(QgsqJ%+JwBK@ypk}Qu@0p4m}7Jj6xdbMBx~m=YTll1VNlnc<;ga ziq$^!U&=7Dd7*Ihor`n2KNBZhR8>yShAeJ`h$CX~Wn*R9U(JN(bcV7$cki zz$T1`b=8zUmK8XFO{@!aR@7LNp$E{&g*uB--B1eWZ9r@owbA8^Ajgrw&~{H-Yz*@k zBcJOwZ$5`S^B+MzFU!2TkzW$gmvpRv1P`37Q{AU20#v`Z?Es=$krjK#`$!j8VqGU6Kp56%sv?{T-! z%Oj1m9py|Ljw4nekB%@wwEju(oWPMZL|dWe|G<)*PABp5OHYuP&(`0LeDrCzsDcJE z&W>a>JgaC6o(0*P@2t;%-TTfqz zSD}5zMZRZfy%o&$%c_-ToV@=p{L?wkXqWyJG8iw8!`2JF2oQw!SxD0Vjoj#v4aXUI zcrFz&iJh_v=QNRRbq8V&c=`_64SDWzt93c=C}jY%9QCm*4WnLH*={kMvl5Id<0W`> zzAr1ufx}p#yb+%r9+PN%tBjYGHRHl88PgLtdRx00ZNf{Ejo(dalyBt7_~yn$$xbuw z_N_rx<7G`gK6kbWykxaCTFUrzqi^auCo4uq`!e33PX(^G9uqdkU33^X5n5< zjFkA)H(YYK&u(mlq;ngii)`%zO_!$OO{@_m5fgGUCun^eTxB+fLoJNrIQ3L`O%Cp) zGU-(MEEhBm)Eg8dwJAnHqT_Q@%KF3yWX?)_-Q={pjMHURuF;XzoD%-Awb8~%ebc3X zlLYdOMX8%z&|5M*-58wuwhMYkW_K}W%7D?Zcg{^PAI(gW?O?-3fw9y;^c5Gv1zX!2 z6M5djn2BUv2V+_!he^25SdApm$>=AmI@)qL|4?m_x=uzwy(`I`jY@vmhTK+i*vi=1 zcv98KtRmxJ>iaHxJ_y5}S**5cSGy|IUMfpE;K|EV;lo`q9FPW1HTokJIIaQ@Kj3BC z{-fQD2l1ximL5i)%()1?kkr#ivu`0kBp8&q9>z$#CTE|YH{3WyUhQF|sgJ_|l9llZ zR;dS7R(M}e<8;&b6gLEC7+Lgg7nyzv`o7mNc>HKF0$}SIMn-JnXE3`D`Y1ult~5$y zNpr;7fHMuen)$hu_l1SqBgu|P@##FNLbD{~r;94rqf8(x8geKfyX9#)K#dSh5AKC>WC{4$E*6G4U+~KZG2q(Pmo1}G2SOJV9wrVBH#yN_&kk(Z)70b zX`*S!`vZ;T`LQm{hjTX5nb^1jXY=Ev{ATq1^x<&bzCp%7S$HL;nGqKnryGfeyuJqO zy5}!6zRgc^=}P_wT`AO6AZwc#Z6xj@43AVtKSt8hGcMAwfJ0e816zdwqBvKv&yd&o*S~ zOru4(!!^b^CfYsuT3lz19C)OY(E<+<`%N|~jnChIPN zIh;SjO>Qujs>FQcGz4?MurbBB%usFVl2S~DGV&&)LwM`W#x3ziJ8;j(X33SeVMZA( zi)I)__G8dn!v}9eOJ%?vXxY7Y7`?Gw%;=rPQ0eMv#3_c%m}zvDF|&=9nH1>m5$Hj8 zEjy{F2R_Zi7kl{ASxh*PQ)Iy1#uxTkID3}S#Z+fV*}XyN; zM3J+hkZC_CDnszhyWhw#&e7%0)#b7(opL8v8t2Q|b1?NZdBEtBo{G=@d0mmzbF3=FUd zb1@;%YGb%Ab(t=8xh{3~TqDgG5iwSkOYQwez!<4zuh6nrx@0p)0qhMkc=Wda#jTCh z&o=_LQ?Alw#^^F@=VHS6Rb2Lu)7r1rlH+a3&N6;*T!!49pVZQq3$?8zl%Ire?d2z7 z9&7lgbz@(KEc^m@wM%y3{hUUYk$?v$e#_{3D%TfWF|jaRMgKYr3kUB7jB5}c%&V4= zW%zwurzxxGi-3<0z%G(C7A`&$nNp-xT;X3_d&`1!Ep&*6F&VrQGN-ADU z>MGM;OKQV^GSKei9O?X!(Go`Xf5@1Op|tKHJO;iMyAh4{$t`UoXhz^llDe~*+xExtEA3Zxs&$!uwR#!-Y7~Qc5FBjw3FCd+ui&sS+ksIZzOU*)iLcP|I zuP#Z+Zi4pMcR9|*^IwsO!PAnr2G-XA6n%3-QouDyy@k=hx_Kq1phpK zlHlXqjv&N{O)It^|52W8zzUJiW1i<{j2pl^_f^o7)S&2q)IVb6ozZm1v9gzW%J%W_ zT|9iflrJ&z)LAkUNoXQ|7v=9qxI46IDhrba#@hLjJNvAjKbgE9L>GT$)6Cpnx z(ZzDNYJ9p*LyERE1K6~(c6d%HOc%lGo zdG_$N9{w{A|AB{p$HVh;h;9Sp&n&Zj6$-`gm;Rk#8z8=1_ zhYx!A#ArSga|pkLyV@J`tB3#5!++!9w|n@l9{yzy|5Ox@z{+1`q#&hkp`0FEukk)WJ*E0~))-h0XMo zyC#|s#SD!GV)}UalRSLD!zY8MA@f|7{`^ODTfg@3TN-#fp75eX0{|^JUhwdbd-ypX ze!7RB;^D9L@Z}D#>yPQ>0FnA*iadOthfnqJNAS@Gdf_pU(;XjbY?%vtQDcv5j6Vs* ztkmEWF2Ok(TkgUpX>5fH8>+D|mql?fX7vBz}%z!Tn~SSF7u+ROrFMG za$%;%!Y=H?U(rzZ|I04$F@Ww0=TivzuexNWdt|QDGF*c>jTxe`|G2Qeo^qYRN6lf` z9)UOy|JE$OB|}_=9!P27cw?-}dlf55L;OKk4B^^E|*% z58ubbpXA{K9zNN_@7)*OfNjxyDCV_jAm$klZ+ZAz!E;2^xFY)sjs57t&ehllF6}JwEHNu}-e($99RHOX z{LKN8Uazs=UDzm%{o%p}Y3zUt>!q<;7uHT=f4VR~un;Z$%LO*lf`?q#k)I+iKkUN3 z(-^%$9Y=H?TlpWI=U}|XEYsLgEl2F`pY;4+?*b=lL9QsA*=#s4_c$)oGLCDh>}-v> zW8e%=xk3-0{*!0?*W=fJcSS#V_|HB3D;|ESho9l$$9nh+LLQ*d!#DBpfBzWiiZqvZ zz6Its`ZFyP?~-}RBlEQ88`gibJp$KhCETCybi+W8OkXXN>XK>ik!j`Oad%=h@b zr`!5%9)3M|23WSMl9e8rN)JE9!%y(=7dP-6e>l!<03v)358v9uHvvzh3S34V`aXhj z^QPmm{Tg$3*GC%bKsnZrH0Biz7P<;Qsj=3;SXn2X$02ry&dYGgkJA`;y;HueOTNF( zD{{&A0cMYX?$38D&ewt`xv(USaksuB_xqkmYrDFzuQV2LVH-5&F8hqeumwMmyTXC7FnSropqWk>(|{8Gm2fblc6%3% z^>WEI(-0*{OJ# z#@ycQtubzEcI4W9t1ngOy1+Coc%BRU4WF>4D;+l@E9Mi8Ic_EPipDN*m0hecZfABX z4ry#KmkLx|t}{6c4Aq$qM#cFW8|hM#sK#<-o;F|b-=*SIhN z=DyO*)-u<+WF~uL#%h`C6mAtAd~*-qMC;%#P)D!w$kcu1HW>Z? zSrmW|hRgRYaf3}f1>-#Yd$n%Mu_E;FD?I!p4?n`g zp94PR?z>JNfg}(A-OgwO-t+J;diX~?{GA^Dnw_3o)iDsDt1MUlUG6C~$isKnWv02x zwAL8+mpXBfuCYoNR{v!vQsDzGaMza+Y_1D?TVvdL>L`3lV{T(_))=>yI&$X#b9?!8 zw=QR?l5_%PpMDWB#I0-8f3Jt1aE!O>j~NYs{r;%S>fsvW-an@$r5an|!cIA+jJC(L&@vCZWPBc(zqUu} zTgds}QU0X{xk=H%-qaX(zB<^m8hh4-RcVa-2pzfmHTJv<`?78iDx#@=;dH`o~b|DFpRtp&Hb zu=6xlyH_rg}!hJovg7hU04&1ZE|5pK8duZ)`fkqv9Da%r@-8XzY^h( z_5U)DfTfju<5DtNW4m0~a8J21E%U8QrkBRPb7AdmEDygiyTA-BxW|Q=Vy!g_LZ5sb zY3PrxthE~3>%x|6>?apCM`J&`u$wiu&xH-sSe*;Y0S3n%b5v3Uum=Tu@Ar=)hPfTJ z1DM;}A9?uqbQ!lpUhv2~sbwO15hyS!#_|Zw(n4-;Pte$5S1Sf<%fi5{z#C`$CBL<{9I$og}nvL?TP0-ymD+hkwY!-wU35tQfpJ zl0n>O)FVc|c*D5s<}~Uo@F_0-6!4UH@>_3{2iF@N5^qC~aL>^VvUxprah@ZA zPmHdibAga90bLHd0(2GV0nme>hd~=ayFfpI4uVWr#>XB-Al`?L22BOs0pf~{@474l zy$<56yC2jNwR3mg#h_uJ;h=IO=F%8$g&PZ+0IC3SD-<`?aN`U&#mofF0?h_hf-I1L z7J;fj%RnnYD?zJ4)u1qFjnr;1in90MbU)}Xkb&F&WKagE6)4w~i60wn<<*Twmvp*@ z`$vJ>@7tG2XbbjGt(UqtjWTSkD%oUomE~_5Y3Y4Dl4l+-xl8Wdf-Q%=He;jW_(9l- zKW7Wh)^El(@g-Y~gw*v=!O>KYW1N)4;{&W6-oid~8W1ZrZyLc9h-9*Vrh-a998dpU zdajmcd_<%hzr&4T;qLDs1kgC_YzwC5AvY3Xcx^*I++uV$o>H=Z9bV*a`>xTh+f(R2 zxGyFb#Jx+mgJA^r05Ol}twEze4SKYKB~Xy-Rlq*wb}^b|E0I0#;$?yJWz>7dE_I$% zO^L%d6t@~VCzV3N-76=1_;--LePcf&V$laiDRwy4eqd~%ztYxX zBloM@j2XtA*qnKLGPb*Zi2b8a$%GG$PmQ|_$$2ZjwTyTzHYf7#`ofQl*YFkt-;S3_ z9~-09of6v1PhEa&ysy@WYd$gJ)p4G?`#8@X{M6vz7A^0ZCtE+mX8nz_<1@T!F(;zz zrO%CRA=7@xhI=`)K-r*tFx(~&i{2fI8Tz`SH=pAgUw$V1@@4;7AVKr208o{Hn6T2 z|JO!kPfk2+01x`@0q_%%J_KR_=RtX6q^&{3Sy@C&?bpUAALBnp%Deai)`*OR5N>$u zS*kyX(+xGwg+_YO-u;Pm2#Dj7JuvSCd48S8>Cjs)Q|CQ+f;>dQ2wUkx$aGAHyxlLH z1Kk(uHZYVJL!l7FW8cyGdS?qOE9T{o{m6W%jCn*V*Wq>U-bdw`*Hw1n{3DV5l=EfB zH%3LPKMvwAE&f?wKj?6M{V)(;pt~5vztUJLV|N)PtvI=}(rqAKm4YA|Kx0KV?84sk zbLAi;4Z-&AD^yl4P2kZNG!$gwKkjF8C{fCu#BSO--x^(%$hvQj6&=LSUGVs)q6x?w zu8DFyXO}#zy~mzqHJqo|b(>_ucZkPosr=3eHec|MQk%cS+)*vbyN$y3-q~^CKb9)r zZ4}rWtz)F(2j%xMgwK@~yNyw*qa^P!@-8UXp~Z_m5B5+lh|VL%KxA*ZF^Y1KxG{!h zLm_w!k#(5hMy-Bb0U~yjK`MyPioK${qOu%1lJN&&d7Js#E)DO6zJtnh% zfZLbJ>K~BzI1~KMvmfzJ!V^+ehu0Y9@O*g$|B>e_8gRT@x)<-GJt@_DjdD!aO@A_~ zWl0@gd)WDtF%W-qt>|Yg0G^T1&v=RFrTw^8Z2j3dMXeHZAFiRRW%524@T@G_hroPJ zYW6|+c?s6pQBbizVn>SXX2DB;G%^y;*A07t7R*#HvPhonJAn1VrTcNgcu7#IpA7jO z1*QXFJM8lKxH+*^zwpHuzu8W*{&3ixeiJXr`~vnyjSa+B?fPGgo}rfZ*A((mDLaId z*p;9=L63l51ic5^2~r4-W+47(!YBWH2F`c;`EZR-d-!U6OmaY2mZqAJ?~2`1(zSfyMiCkh&jgynn~e9-OL&4 zn}@>YD7DLW;X|A7rrUt#Sf~zAW)42OU7^f=>N^Q5b1c3|9W?Om-aWF$FsI;a)FmnS zM$&nvIT4?iE=k4tR@3Z@k3&1>&E(8jDA^kUrpB7rtDmGU77Bls?mjb5?UUg?vkYGX zUgQeXPfjJ9x2SryzeJK!G2$Afm|ct*Q+lVE_ZrGhdokw} z!vK?NE;LO1vE)nf2GXyoW?v)Llpc-D@rKWo#~Ybv8*!%m)W~dY#G8`V*c@Oam@=}l znXM8f)EKQwl0A*ha+NIo(%_L4nUDtmq)K&~IaIo3pu<|En~$r;vMwFnk|y1on5F!? z2~EtQ`1T&St`gT2{m@hjnj$AdCNxD(CUc79$1L>q(WYhwKD*yE1M2-Om?xKJn9cC# zD{)>R`vQ1 zIWuTprcRZrAiUj8{5jCqT_)tf{vJ}BW6o4PWmGPTohCK8a6_?lZEaSn(`7?zNS-17 zJb=AqS{}F(smVhJ_m=K$%siuyDbH?3KU~+w%pNh{F_sTbi8E2WYzfE$Mtjagr8E0!|U%uJQ z=%<p3dV1JR(U>%3LDHXupu&6d8% zWxudJzQz+dt!rl%o-_c8xBzj6(ioh#1v#U)%$qNb+nHSl4fMjEVuSum{)OIrv8@^G zg*|F7^5#d1UF?ND#fEtErM50USGt7o#fIHYG0 zL)RG@e;#7N%dR;bThH6`EbsM*)tmyCjUy7-V-e+oX?1 zUer=iD&E7Nycv%?wIf{F5tC%2cd)VXQ*6;p!9LUEU&4QPGTSQSDom)~;7g3Xip(DB zt?-m06W=X)OM)kvwMgnuGN;Lpr<#4k_<$Y$J~BRcH_!}(@$I@CrN+wYQ_Z@|xo+Yy zGm_YUrIzF1ED&$ed>~$k#=%4`jFH&<)i|L~xbWq@1qbkWVA0K}?`8%ro&Y$iemU*U_!QaN-TVpbqBT9t65|>(@~4wV^fYs1cMmhe zm~;%myU0Dw-gvumOHWKQO-?gA%7C|GQ>;rfQU<}XQBQEOKP2jzBc7v1^q_+ck>X-A(25QvM9&m^w04rZr|>5gna!i6 zC;J=RxsC(wzQcVHn7ihB+=r6y2%;sV4!|59Y|M?|nK~F{Dv!yqIKFvLAqiM1L95Bn zIo6FA;{yswz688fpLn|cA;wHwEb>hnPVv0Gs*u1L=5SvHdOAU-ondxQ+60twmJlOf zy^)Y5XRk|WAwQjA&eKAb8L{}Y4YTll&xIMW_?E%FNqAAamwCROog%?2lkxWrdgJB! zNmnJ~*5MX>lJ&e2vqvjdf&cBVJ<*jsoItx)s!DJ*_?PS`F$?fYE4c1*T5q$rF_{FU>>Ca@e--v96_1Pc}|IIS14=%J*C{dAm z6LQ(Rk(~Z#V!pUpL!}Kc{tn-)^r?V3a~^~JrRJ2>X<9m>U{R@A?7IcfI9Xk479`$^ z)2mUavD7^0^QSu(oaul$@8n6>zOW?}p4Jx^<)j&a*%EZm`)8YN!;Q{HTUCs#J_n1w zIVrvznKT+JkXJv7OOak@n+az*_S}I&JU9#R;2joc4A#ekd@hI~!N);-k%6r)1vQqs zp>ck!?pA+-q_32WHiO~q=b3ja<2GE~uZ+uxLvVkw zSJn+NyCV5*2-c~4!~KVvr3To_OUTNeOU!WOfi=I(zXQ*$6F0(wi6AVedYFD6KY7&x zZ;$)@sXTRNiQi@Oh}gVv_Hc8UN@Z6w-ur=k;hC4274i548|Qs#G}`<~f8y=vXe^93 zhMQi6MXT%{iMz{rW6ak>wRm`ia!~`n4wy3$FfR=cx7>Ulc;d8%&U^`z620cg5W5mG z3>h~z4;b?(t6LI^u{<+cAMhyPg{OhMfW(PEa8IuSfwJL^)c2H)cVv;=;e={i39-Od8-A#sM@0;7 zQprFZEd#;ZO_921;sb-6LUdWZt~3MZ6k*3RZ3SX+hIF1*7iq<@Ml{oEQ>6RVX2BVU zp$gIswZ4zXl5Q(jf#*PW_Z}S@dq~?Iy4O=;B6x4>Ga>D+r5|KySPZ$N2$j~T9Ne%d`!E*-K3yP7(&nEh1=Xf(A z^tjfS0+{kNVvfdir7_dNGv9q-9tF$^TsCF^cqgAc-)VQ^k9=G3PD9D3gU4-uveUAd zqle_$31(J4jbz2_)_2h`uXnFzW38&~!G;-tk#(DVI>8((tJ3lv(C5Nvn|Ivd&az_IN5Ys^6UeSqn_WAM7)@jxZ}VSLu+yh(Vfl79bj z1*+?LM@Ug4vnrqFFvZU-^ z_!;Iw$cwhUW*&U~2;gX6 z<1uwX`z3(ghE#!P#Y>OVQhvQ@g&x)7tejqbO!M>#SL}Cycrfmmzf9*NvH8bw!eC?M zmV($rj_ea2+2!DA$_iZuJ(=Wk#Izf5^YtY1q8q#N26JZSQ@TiWXO-S)7WR2sXGQq} zwd80^IIYqu_5fS367tbKu=+-`r2R91-G2KwcpAG3X|zH9DTtiafTN8mn_>n}de#d= zLt7AFyYlC}`S@)ZYt!dt#}q6XtC1TW!;Nn;$7a3&m_BCYAB&sWH<`oRzlbb`*RQxj zo`keDh*rM@Jlg8UH=}~^ad6RYpWprx)62+;ZcxR|X7}`0PE;b#+S(0^t{J`r`^#*v zO5M#EV{1+*DxIIlmtxMFYW7Zl4Fb`guQ}=q%Bxe&X085%JjUROM*7;wNM8pLw(WJK z(OxQ?W)4q(<2day%`8t}uN5D2T>LF&$)F8@-QB%Wi}ghXj20(`-}K0B0#740BaLp0 zK&{LPnHl!&!aG{uv1;+{`LSnh@fL%sHlTPAhY+t8rJ!sO`;S$!t---i`b0V$!6h)#trM!0n{(9LAvsvgfoHg0nWZlcL{>!P9uB4l(>`N%4fl>1Tcp5}w*f<`P-3eL7Nv`H= z!E@DmEbuG7OUSd9Y)z0M_m~;^)XT$(?yn%<6?`6u&LQ4aDj&j{ZGJmn+Qp9C*ILeT zWIM=l{l+Q%8{~OybE`Cq;DNXaa$c76jK9V2!_r!T?N{}$^LQ^IR! znJ+8#yG*&q4EFp3(*M)YKs|P42ac<(<{qTz{V#XlnqD3KTSmK?u0vZ*iEh())h1g%PV$U#$HN;W_u487IX- zFvV6BH z%96?drDTe?q+mrK#1|9sgK4TvtHdyC1d-^zT3rcOHa-sCTWOZ1rvZ)*ll~8w7Jitl zeE>hbHId@ExHD)w7e86OI@cVTTdG@_rR^92-kC~izn=vPnm7B0?B;TKuDPO93uNXt17Eg0Xm&lREno&;Ul8598FVp-S0-K!3XmV& zilT?GplNp;%*J(U5BQ(V?SQ;!b8(T!?u&oRP?)a06L& zXtCK;4U*Eu=FIewzehj$yg@!)Y*w_o1#mT}4m9$Q`ua8p>gyi?y$bqDMm=JdCFS86 zDnBEJNA3^A zmDdz@=H5(7=7V~H*c2Xoh{QnRL!@3PdJ)oUUt}lU_7}Lj=-+V(iJTD`TJ5C%1#^@% zT566q?!hkt`PgqaZ>f2akI$c)%HE}TSbk49_^3He;m?Pxo`Jt1|NLWSnrgv(R+$T; zVSPbVsFj2dEi?~iQOghVly>Cz8XNO2l=5jm+zemcK<0q4Q zWW{o`%+5%c!^;t+ugT$NvG_w^E6h`HzIQ*)=d3Vi*dl4t^hub9KW_3Qb_Uqm!mFRe zQzrZ8DMKos#Y?s(ey!P zLMk5!aKQ8iDXF>~%j(Xn@H+-2GM#zPEo4T7=B&a`s%0&Q2DFDKG18OY1U24P%z-X zMjLS8z_Qac=Nhhq@Vw)0Sp_zU0Cjg=$M!DFwG1)H$}>D=dGJ`Zk2 z$0eWB<)i1JfE7}(848FF%8;RRG`ljps5w$_s^wGX5Kl1FdDo6Jq+zqGG&wrQL<&$C z9Q%Unb$0Z`Ef_{r;0xZl1-qCKX>LH{tdNG6l%Ns85HfQ@QhG0j9GJ=>g4P5OCzm7n!sxQk)yYvZ%{T%6yc6Kh z*ZAP9t!OyaXPnaVDR#_V`3g2{DRuq-i=$1}zv`MB$@bW*ZHr+XWD8z%P8=XU>up!L^D;yFK97AA@4f9hE%tKc<3Kz(K}H;PWyz>U z*8nwQV2GU?S1cXI#d_3pCmI+h94v4ufF6SmMfVGrG&N#Z>j5cv2YsrS%zejI7K&j> z;yqWoeD{uPzT%uBmG6SGTI%1$W%b*a>o# zt3)Qh4bB-yQ0 zSJ?OwHhPYf#E)H7HgRB=YnlA=F^n>lx$z%Z_ojcQCc@=N`HDD<#2@2P+s2Pv@h9T` z4@@dXif>mW_vM`5`!OvX&|4W&`&?gz6yDmWX#h<%M+F`CpzW5y5Uq?!(FHTId=nL0~ z3r{$j)5P&pI{bgRmdw4bg8%(uf*ba_a8CV5+59E;i@YEUzH;R#JMAcIzQVI1wl06# zE*S49*aPX8Ju745JL}$jJdJuXd*#=zTWxl(eXboSpmATgfFt`broJHM-(a+&TcNtT z10pR8Uq$~$QGN7{D^GL!7JG0AwW7Jl!VJB9-u z=d;vcm0b{fJ#W5<MXR^GmAhMTRHoF6bfLihdw_b4pcEA>CP3V>;9#k7Pl1^*1wl>bxF1X?k5 z|3v$-)`=20gq4O6ufrM}7l|Er2zPJjxrf61)*Mnsu=5c7+Y7-3har=rI@t6t*FHyY ztxB$|u|-PliV@$&sY~;}U3F?YNHlf9`d=<}N8o<+#4d~u7W@RCrQ}SJWk2IC;DFTs ztOl?BKf3~ULiH~Y)gEcK{Gtb`Vo5vdx>k{d2FheU)IcMs5?OUinvU99aLLi5FjmDR zU+u=Dg^sp~)lgX={g2`fij5OQI7*ibEgY^!>=P+*rjZ*?|nAktbOQ^vZC(ax(3y!hMQ z;^g{jUS`EYWooW{jUki1urdM*Q9oUPzSE#y^+@}_d5u+zG8d=;~B~L>lGF6hB$4jJAf^$>C&R;IvkS=+(z0^R}}si+%;0P=={yV zNAmkx>fMHK=vP+$O8$<^Kou$1;t>9nE28jo5O1$ul~HuleqHS~(oUHWg)T*$ zts1SClcVSgew9gHBco$Z6h7lux!!AZANW70q^?5rMzpP1M`Km`0&IhdSuKrT!#|`a z*8fTYe+29T`~v8LwZL-$*8|o9Jjh1S`npMSVvVA}TziQxGU*)Pw2iW))1u-#A|5WHfGojT;t0muutvwSm`ty~o%oa4Ru4pl}ML4U8qt2aa4vOCa9x zoq8$gx*?hah^*XsAd8IqbvDq&0m$O?;LdpX!u|zz{Az@7DKU)mN3S{_z=hCjQ4a6F z*5d=6%dE8El^u+9e6tka^c#-zCx$=n^#nJj7+oB(*V%;W6XcU!MwSb*%M+PaYA`m< zz&DpyNcDwqu9JPnXm#`4Th{oDQgxXsdwoWpx=fSAbb|{Yv(gPLpGx9DwfZO$fHA5Eh$33?akYoo$4c+4H0T{IVnY(U-MftXk?-#Y)3>*edo+cjGk2B5CPvoXwcOQwhJQZZ7d8WNvA$WB`|ob;Fml57@>y_$r9{i6e)@%Io!uM z8X-bWCv@2keT@qoi>11+(Ezq6bFmXlHWU~|2=*4(x=Rig4M5F9e1cU2QIfj$%l1J= zf%AG!ywZXl3bC5r`btDZrK;s%7ra$-=@26&c*rWj2j^cVg`+#sr}EpJEh-(6#v^@o1$O z4>Bfxin|so9#3Z0?(?Q3{0|DErP8D_rQt7Trb+vWlcSG2GB4yM#bOtk4qz9dUnY(Q zNWaVO!fwK0fLs`|YjG0BpW=*=yqK3=b`gLy!=-V#;Y%iadK=m!vv-t+eumGhInI`b zfkw_irm`=xk1FejMfAZn3uhV&jPzf9r0EYHA2tk>&$j&X$mRG%;l^xtlB^D3Uu4C_ zap}3t#XiNZNv?!J0Lns6{LK)54-;?y>K9#P>#49U`jZ$bU*;{8jN!(FWcm+QkX?of zNt3$SFyDKJ!<2KSyu=XI4n1XmiBV%;21XbQk$7Z;Au#=#kztzrQAW_F**D4%x#c;$ zmepaj(XDn~mS+sv^Ry9Go5fL|kvIyj#n5!b(d~ulr11?S=S(&yQ7HgQuf3m+YxdV6 z?Q8&7Eom%dr<;)18kZ=0N5db*)>fX4F=LEzmg6t7Y>e@WU73P2v9tQ^I=t<@WUS%A zcNcLRjeU}1jqCAZcg{FtT!5Wic~~%|Q5*ng7CH^!g4MCE^sT1?-wokk0hM8dE2B( zaJ(_DADgQ$lDY$^A(HUNda^E>jiM3%EW__?amf7MMpl651hNHm%kqTR!x2Chk@4tj z=4BByS%$iHg}BZEP@FHL$_OC7D+FcwLdj|)!#Ev}E`;?_Js%_PnSCCDH0aaC!`erl2w4Gdh{KfF~I}P#nfaM&A7ykq! z6GtF44uKcW1Oe74F-2{|W_g-i^)$qZYt35nS9hj!iNT}(vSjTVZ&L84vy5R*9HWQ{ zOxAe3Qb#joy|m^HT(f1^0t~AFc2ydGyLGKbjV0Id@`Q_7{Q!)x-OUde+h zU>v++mEuW|Bz4maU+#aA2d_&v-|X`7iCOOt){5s2o-%?5D)P%qWs$(~aqBo{}#!&M}J9IJVLF zX-Bl^A%FlHWR*8d-Z;m&IGc)~(#P2$?N(pYm1f`|HBY8V8+FT+8OAJ!TQ<)yO4O{A zmN^?hA;^fT&^X2|@tP~^OXnDw&S_$3d9X?Opm}Q=iNy)tyY~=Lw zjnKB7o>DUo%Nf_4Z;Zwr&F1qJU0j9XukCPy2N+zI%AN{LVPY?ckC)SZW?yxWMD5}{ zokH9rRa6+?n&a8h0BTuPWq2;pm7NY!O2i85lFp7Qi3*CAmPKi4bqM+7 z;npio{Iy?n`S&!rd@30jrO-NliVm6{(FXKo==*LED`2 zq&I#D+e>kB#l)~FDIBXx=S_N+q&3$A*PIs|l7dT(Om*xqNvLcVFS_@h1DsIFpS{stOyryj=wbjj3H zPk>hn=NP4qm9lV-QJ72>P*x~X4T+0n^Bfq&71D%2xvk#fz7&g#u~L4ik>i};kk4Mn z`D(XZY9u*FIpp>~8d=^`P#(qcV3RBzYbTuQmoG;y#gha&HC;08nPpKr4!>P+5gF%M zh)gT3Ef4zSqPfOt&SNq1=v*Vq`R^Ec6QT0%nw=IMji%V`6Zd8I>TquvcNx~h6DV_L zXWi+a10l=PahwEs8CLop1ByIoJnbngK@u;=(j{%qtZjJCCzCHXKE^R{H97G4Uu-c_ z)Jx|*m<&h-u!%yWQ(zwM8}MNEQXC7@zZd40mpyYqsJt}x<5%Xd9x<&~K3V!iK5RA*ao`;|t4of15{z)<_47hY{} zQ|r2`jRneVdP?Rs#ttml_@9o=3_2GYY8PbXwQ5{leyzP=*i&|2Yt$wmC%pu&GeR4f zv!(7jI14H)JGl8eBj9jc6)awCG`dxPp~|xXVUNIBO1&b_mz~Rum5{0OMm#}Xp*m7< z?TyBtL!$SVlADZKwu#rJLXnH=j1>9sCgUy}S-sq-3ta{~-HiIH0@>wQU_=L9XZV9N zR~V0m_{NHFrNPZ43sxE>DtiYBt~AQj8n9|Mom02SsymFnu67i^ z<1QmpEq=3-1X@*JKx7HoLHFHQjYCV+tv2#KCuoVLwJ?CN`s-ddGJ|{SjE7up^ho1V zg3Fq9#y+KhSXurzV`uVGRFCd-41oQ_E0w<*zTgcH7(HC6I#G|TB*5l{$Ka|ze8?CE zBklCC;c|L4-I$<%gR#ch89bHOoKAWGYeiqQN%lU5rR}q&>>;$pwvEQg*)B|$D4Ax_ zrYPVoseIq*bIg~#dOY9R7F8G3VH-Sv2XG3yD-BORvW_@j*-aU$6B_u@34P3Vow zWWy%R`foI3z1 zUeXaSYFvpi3py)11@C>p8#SS_wXfDw%23&z-oc|? zxWO4882O<}2UmVz>@cMJQ6oJ#ZRNz>^XuuKxt?p+4e_FV7TxW+K5#O-K_(^%WUJ_`sy>vgRYqB3V_mcgV9Lon)tD6Q84}}nAUEFBpxvQigy=j-jBHnW*x|mjcXJ>qnGM#kxW|k)3gPH$`a71>?+SVzT-B3G!7BY8fb9rGmjd5BL-Vp^P90l$zvjm zHm0$-4w+%#n6cft%8+-eaOz$M%N$1gSc>WN^DXdWOQpdw%bp%<#yi`*XyuVgrcQoSW;rGQD9H@XA=3mKTB^pg1l>RBXjp_5*l9Ev&5q!sEZjsw?`GzoIFk0Y~o z$*I_sn{1wJ%aGU6EK^%`Gew~DxK2I(3YAssZ7K3bJit60%>Mwc`QSArLoMEo9OUT47 zW1DSFrd@7Eus+i)qlS-mG5Nye!megrGUpnR7PUh1vdkU!z<4Cfoa?NC&0b)2mz(_N zY0`7JiK*KRJlb56g>#^%F2~r~XO9wp*BWIXJRAF90~ZREofc}1jA6QuxUWC%w}%h|Dhi9H(!rcTW_hndeKvqLIB z$MkMvzL^p!$N7e@_Lo;uCS#;Hy8&tUisvWe&$)Y z_V+hK<6EB8^oKW6R*Y=4c{)4Zd=r-{js494GL#qK{7z!{W8HN>&67X@8-P2@@bsy` zt^&|yZodo~V1~SPD!*eB>LRJKd4QQ8GV9>}0pyEa=>!AS7%sB?I=MppxpJK7ND!{pbUI4aGmK2P{%YtwS)5kzsxz@gA#57)RH$EIrjsw+q( z_k9c+YKES#WJt|WOZ)STt4?f)H~KFq|vq|=9)U0^tB$ixP@&>pUQSvSmlGK(r> zRcQsR5*xM_7c2|AJYTvVC*N1xV|wJyQ_ZEST{N{@7LS0(A3of?N*?4p>BAGyPj(GA zXFFFL>fBq2-G!ToMI~lvmt#-aQG!8Kq`Abbb>5@4)yu@cn4aJxBh0>rlJ|?z=Bv&> zg&qh6w~aARb6~?&;y81PdX>Q?v&NY@&U@9yu!PwVk@iR1do@@;&TMuhWWt@$k?jWz zk^SRMzdB~+FQ}2;tbY=c)<(taqT=@jTgGF^fYOS~%r(jPBbm2jv=7w?vaie>7hvH; zG0X>`?3j^Q>u0ys@g9itwki_$DHh9VhNR&yh&b;u`vS;=(C^9C^AmV)M_MP~A9!F* zQ4kL(!kd6#0iF<2;Re_^T?iSPc1F@_JQ+6IyQ6jCK*bD1;S5R3-l+?Jy$!8>vpfXE zx+c#^*%_w4;@&oNg%T2R55-ogo(tFf;lv zA6-ObzE|4G_tr19Nw1|1?E6%xO4PHi&MjaWhj^rZ``N|(O{PpV3j*0TxrMM6`?a;^ z5REx4DqgJjb0dw?(NZF%OR+^@8u40;9OR=W7-viQ5T{s(Pg96r>^Y2-Ts5Xtu@@TFOm0<>`JkVp3<&ASiM znV)4d9A}4R2sJ;t(#Ip@1iwHyk?s53)2%kgQIU*B+u;O+6ac0ZbA~N6=dD_(QXAI~ zIOZE`r;+c^co~7MrUk)eOxI^{CUA^gKgrB;465}{^#xcZO~JMv1PW5>5^}*ME+XCu z@%V`N&p0kc_Y}5a6XKB)zKFOsJ*M-B71{^yPVkd~XPUjk{v;wn8PQFOrq$Q5il+dy zz^vx9U`SvJ#ezw5DnP5vM1j$2xEXm^zD*lC&zH<5{wR~ahU1@k8_o%zx6|+hXaXcV z-44${sEenGtdA(3-HEiL>~K6nia`_j>R+uU8A-=rjoN|9Z=2=hvoGtX7{caB8ij)<~|d^ z+-!oaf)gonvgX(%)Hjo;j~cv=L{IoY$P-G%S!UmUtL*hN$of(_ug|p3!tWEgl2SuPF8FGBq)vWqKCOqQKs;yXSc9-HfGwR0ur{}}T=+suOX`a)EvLMMQ;q=LUv6nx z0NA#*rR9@X+qOm=@=zT1K8j28{HnPn5O%5YK#+i=7sC;DIM)tuLCB2sCpY2~9a>X# zx9k&aOXkylfz3XT-$=3XG&<%d{ygAG>*sfAc`*{e@Jc(p+753;$Xb&*+j{=Cwzawp zxX65LamJ~&$b5fCKA==ucRN(>80Cix)vDL3W}&QY-u6&tN>5xCq>n?WkX|W`pYx++4GcH*l zW~GA1K%_2jw6xp|*af)w&CsF#%)%QI7DGiRACzwAm>CyoYq}FS()P)>)&hj`MvBsH`w7{5mG+Nvf%sH zZxr;l@vPhVz@LQhK@gQ7$TAcV){nKyV`MG3~B1|S$XP)tZ3Fh@2g$9t7m{DtN@2? zhNszKxgDNuhd0~dU3SQ(C;eJGTxW+5+F{TRw;3{-ezxUm~28&zb7gQcX=;SXp#oMfY` z>~M-5Y6VWW{G>Zn8t|t8TU9w&}^h3o$9zHox9Ze9R8(?eGaZ zeAEt~vBPKW@C`eB(+=OZ!<}~cfgOHihySp{-JviL^Qnz!vcoUz@Jl<~XNTX~;eI6IorvlLg)(LT2cth4n205Xotym*vSr4?a*h3oe>TP z!>IuNXeh4%h62{3gPeu%Fp>D34B(O!`%N~WRCZr&Cd#2yV}9-MQFyAh0qa@nv&IjB zga*$XY=fE7=Cj5RBbmcNYcfA;ocsvT>+ z_T|xw&CKKt$ehq7bKWJUKl#z)cuu>-%73M6HZILE3u7qG0%i=3dZqQnPr8&*J5ebwjN8BjFF6o@e zlE{Tzwd5?FrAF3<*ThW+L`%b#8Uf%hQ|cF(nd&tO2clU3Lv}7OOYyjvXIY*^;z0m1 z(*+XO6Tm|F8x5d<+8us*Og>wH540`0%De#8YP!mPxP(Sd^!REYS%XjOUTvo2)}yL% z$X5Z_4xo#n+W6CDWy|6_abxtjO&Ugngd(wS;{bGXSIMkv zu%`b+aK|;~5v(=_U%A%Y&o^c37n=>Sn~;MHLd&ojwR;YFPHZZ{C$BeM%*rhY!S|M! zIB@)p+Ln_tBlebK0eGR^%K3jVH-mWJAIurvCv`bec7wSb*qt|+N4!sku{)QU)y}64 z8Igy{$H$z+P;w8A;EDxWW+Vf`hL>Dhz`{jn4&C~2I*Lbt(LzCl8>%8#FH+71&|GQ)J zf}>WLKRNMGujp3Qkyh4VvbW?`b8t4zc(M{GWc^e&n^d<`ytLGypC7yx&yGl2ECsij zRVUW0Y`D#wl}gG~n=3hmI!oRv+|Dm*S)Jxd%N-4Dq{+=`X+_VWZxO|oA;<_^A zozg~BW^Gqg?zX7E-F}c0k8`@sf)hxSbB9?O^$5J?4s(0%bCCVNH0tMVQmrf+v^MH; zT(>c5ILkZD*(b2<$_H@z={2?H2=8X_B)@8Ds5O0FYL4SecWL|-PqO}9Yrg3X8<8yD zgl!OSZ*zNUJ5ElKO^?N;OV$y5;_uj0>|2{S+u^~J+Xg&wt9^S?yzDs)mp2X2gO?JdLYa9CGwSm>n_|9y-VSqCM7Xz*U+z)Vw|8CQN_o3JnS&i=q z=01UTV>PKUR-Gf013=fp24V*uEzL_YAka6_JLdyPvRbNd!nTA<3#|AvnY{$S^br95 zdI1%dODj6)Jnh~%1gJxR6wU&Qw=x1bp+F2{qTKKGbO_S2h^d(2tMFQEN7 z^`uFJ2JYZJ=8V)AZL^3PVE=?8!M3e7Q>4P>iLV{?X1W~fZg~>e5Y!r}OVJpRuKyB` zM|~xH3*Ugo_KZK7-^jt$c!1ks4W9ho*()~1(Lri@;bWKwU&WVKC$BL_tB(?5&+r;E z)6pQC*Wh{9E#18Fz2|_fZj2tdhHT0ndL!%uZ~-`3JuBF<#%yq4!#&>d&j~OK+m~&@ zcBKW*1hBm+Elr5HO29dQ=>Sd#SR188gv`qsN;Hn@irl8nyqSRU0P+C;G{uAwGGSqM z%Ul|lX>yM3k&+1>Ur+Wvwg6MTfE)k^(31c!p{gNMl-qZkY4Xc&?)U`yCbDEkocKQh zN6_`GGgDGu1~GAzqqRB9>&!Ce*3jd<*!#>Lfo3G10$@m>$P6*J4C89;YXsq)rTNes z;UqicHBFph{|KC>V_vF_MnN_E0Qgx-wyWgH`^@~*S8S14?^clmZ^dQ~cYq~-(*WGq z%6aZ@xNZ+N9fy|*_nVU)pGw{R7`CvD?S2&Y>In-=ehCb;XW<0+3aQ&^$-xLdzjJ9DvkfQUDLbA`pUpH` zx6Ujaxy=YQIN5}?hwGjIS`gXNSZGPxZCc{PwBq}lS(N&EyGd1l!w|mcL32QFYT)mn z(ZWP(0KzH_OhyQY_Mlmut1H7&-$1rxgy9l#od@vB+y~9FQ+J#w86;HzdT4eaO7JFV z+d8Ty2!G*QK-1_wfXGsMAdV!}@0k7V=Z{LC0Bon3v$oRQ}qv^WZuk zHsh1uL3$f~^AlC*fS1N6$(9uC4&U+>UiBFDhF3f{IrZ$Q3X7kD7ipRhlH_kD7VO??R$BIu?A_ z%_nOgHPe&dLt0xG&d+wK6MA{3KE0!^_|D@<@ofp5^Z7JBWIJ3+9y1HQ%mNYM;_>PE zOm%)!s+KK0XF&Q0N&E?$f|zwY^WaYvLw&PI{&cbLBau94RNDYFZ)zqLFb1IcW3%4| zj1~Q-VyxJ>8}EIFREDWJUisUIZ^bE3FU^ZF)(oHM!D04~W3-!>;q`Rp^kFoBIXK;+ zttz!j-9|IBEA2I`UHh6h!}QqQWzA%qJf0~f^`>tQTTQo#zLTRqBAK6wIGHmy>!=H5 zeTdibG&`>8$TuHAY3`PWdQ{`iC(M*n=?ZcH?6({tXs_g>yF#Si+0w%SsH5W33#Ti= z5?Y%urz=Gw8}=%)nQh10)!rK$&6I@y7mcYMDq)RDH9jvrlog@EDC``&bXJO$B#zSQ zu91jqDl9bPO8m|8)oy$h?SB(?bA2GCo6I#Z&8AIeUT=2Y4^eMzO7zH60et~f2TN3q z9Nu?>_byVs@n>tV&!Q+B7aRt7EI`2U+9znH^DgmAxF*~npu_{%3%e+2 zPU^?bG>Mb|_WY1Vw0ae7fy&baj|9zE91wN$b7tWgpCK!gD*&|avjObI6h^ZlTLK%B z?3u>)_}tFhs^jA4&Go73={k~$reqTkc9$B{i6g@{hu?pau}ARn-%*>*msCY5L$(z3 z#2ml-3-<2gc&U8BtWEv`Jlf7LN^bUM-qGJ9JzrES5IB0wm!U0eFQ~P)sm(93O>M6u zEqKd|=Hm`7ugr;TL003d=xP9$2O!7309Kd3I6M`LjQ2yFzLh^b&rnayz6LMWn`Jnp zZm!4Ibt1^fg56kWrz!jq_$qGX#8)mB#(U1e)9E(PPydKGwau!t80MK_;}|E;GZCj( z(_$3b=`2g<$&{v-;Wn0RHM<3VirTpL4dT&dGy)gNGicMWh4hq&At&CtKB#rfy{Hd@ z@NjcA^08}2Bya!i)KVvf4J z8z?9W4VR+N$D`G(eoXGuE#2I9KPkrF*4 z1+SXE$%157fGil&aWN}fX}O&i$!;NVky+DBjIIcepk?I$#jHBp+yp?5vER3eedp z$^+090_De;-UC1}z$|7K#2}70EV>H(6gqXnW@WoEJypst<11X-us%#W^5xgfBX##Y z;xq~7NtVW8ptlG@C^_|w$Iauvl5X#?LOdGxK2aE2Y8 zD-CBmd}l1MqgNy3%$vpY$JrLMvV!~Ib2%HkmkosGTGzS*zbNi;pYe-^Z2E@(f;u_~I?I$8oer+NT}< zc005`9Y?D^$@w$TZ45%xrz?JGAAPia^snuse`_CotbH_h;j|+Oduv;CBgLz|ooS;D&xZ*p|x5ckrx*m-tA@J7yr(39jr-cj0x+ zO-6=PylW0nFL`-`weMox*zuUuzh~x{Q$VvwK6=kw8UC1#ZbLP#l!ZI-_5%)<*ojA~ z>^N-w5#oB^EIps|;#5RwJA>?yjn8+^@fWUDTNBDb0tTLHX;83l~KQ;sEeK@6E zsq6$z9Q+t<9ZEj>u~}(Xy7C|9LRs|~?g1-y+YRiJ+TA8!_jG>(gnfrx_u0o6MbZXb)bLBh%B6mLnS;#Cy+6KEn%%Oi)i3$1|Z##)i+#1%b~n!R~`Q z3GB~PQ)UXya_GT5fW81WH-B?69b`xxo1OUEfZGhn$2EW0$<$^BaIHPjkIZus=EK(m zps=hq%=p=cw*X{J8%&f$Ow_uvt{fVvVE#BXQt=!bT~hf4Uh`Y(3W+pEHh+N@Hl$!L z-a6A*Y8r13(|4@;9`7tK*=r66zqvX_>ifgVzP;Bx&tXdbm)NSne3T)SPkpTDbT1AU zUh*a08RK(*HW^(AC8`3jN!9K86xDj8L@j)-J?2e!N8_dZh)EcnK( zv)TB*HA`UE(-7F0HQ!=|gBCGLn!h#6LYKjk@9?x*U7s2px8LmKa9U>Vq!fG(=zH@n zuiN&F(E9<%JW`GvFbied0W6D*4C31F0M6HpMd*=I(rohMU+WQ59WGUNHe*-7NGbXO zS=G5e=uEkIdwACm=E>P3AqjtMOWJS`08wth5C9%G4zlp^#($cxI(mu!5dE+O7R31- zH%a0fSkYQ?2)e%zl$@7QFYH#M0n~jjdGZk6^&TlXhfRLxXWC&bgO3c>9yX_h4z|dU z{r^J4rolQ{YA8>qA3;?riyn0ch>RL+JWHV^LurB&IcTBGCaPRAFmQ_5G-cEoQt)x(-s=V*1o%fxS4} z&X#ywfsMz|Zp@L?nu8+g97!k6(XllLU7gO6d|VFy!HDTm3P`onqVz1AIM%8ovg)BV zRB`ng`qNwRpqX^O))ILyrAzG8Zi#nSSnmy$HY?2NZ(U;FdpN7&-TtBV9U zDYcfh5Os}nTbU+ja1Ig6Dw2!b)-Y-fXdWEuw&;{{JXRrM(>xYGH1>)Iigin~$I5iN zO&MUhGo+{28s_wcT;C$Eb(%9hbiK=Kb#u-?hHc=ZWO%F z9pn7Hh+-peiPuU?tW^@rGwwJZwRD#O&*4munQ_*nTyEneke=n_0yt!{?Oy|Y21u6O zaaLaLFyQYWJ2%0KpHl!rj`q|n>-R-e{4aLeXoO@s6+jPx@mtLs;}NQH z6(Q581~iI#48t_`{_cS3QlDTIJ2pm@pWO>-k>x)c6`v&~9jt=vZ9tPf2QwBu1`r2m zWnbOF@(l?9#UED!9GJn3N2uWzTt@O#&sTmI^>Tmm_7Tyr0f1)(&dEc0>4{ukN=Wk?te+wvkhHIXd_X3HO>R! zVAPx@kZo(BSDVb7F_bLF%}Pb8H6ful(r9fo^z9N%wdSVw0g7&fEW!$wqBP6jFF%Sq zn~QqxYiHr4zcou!npGg1(ya84Mf)7hsnYn|2j@DJ-airzxR$=GCKu1eS z0W7Iri=B;IzQl2RThp!kl7~bS1{ZY3=#qL8@KkDB4F&GQt=5(d>(9wW$CW!b6FukT zXm;Z6Vg*u%+T6V07}klb>0+%jwF*;!+0-BVS-K_Po z!$3x+ISwB9kiq9?71`E#-cvO`_)4}l%fPH)d%jhGFOAf@y_p^9!tMZok8)?X#>mnY zo(wO2)fvE@As_X$@Qo>4(qphWMgus{qNrUY&>P~x^9V;c`9cN1j{R-78NNAeHb&{2NJ7`bY-a-~1%H%+c=}ux$q|!9UXCe0 zRl$)j1wbE1ozu0mcqbstUv~7ujLsWu?qvmC;oYEQ#|mc3M}46!Lw5JaK)56e_crgn z;Y^X(0PZO#_OnvXs0I~(bY85_97gcdI#6msob}f_pgBeAfGUMojTt1B+r0jMFG7Bj zYL!rSl9N5l}^}4m~@aBTQ^U@b(PuDzv(o=S+nZggUYY zu;@Yn<5K|h>}v$!(eGr?6F31-=4{9B1WhjQFVSQ(PV$Sb z!t7}7Cm|`4dy+JawEU@kfM$VY7zeN!7Q-!U?SlQ-8CPJDMnoAY z1Fh$qsQ8z5T-WhqPPhvP4z|(SRvV+@8=~SjDr+0s0Q7Oz1{`ZkNmvRMOiOH2Z!` zMOK|_eeWzY zooAw$PO%xXXR<3^eb{-jDN8@W+iV#XR+4jy9T`;t=W$jjwk#UR9Z#KKG0luV5``~B&?cLG-CJG zyj<++Jyr>GIY$~Vz?#j9Al~XKaX8M!moKbXjdO0f-oH^;iqG4Ns(KLYgp(K0THiqDLS&yvk^t!0kcQgWG9?wBJr z3@()>26J(OgB2VYy)TSTVK#uKc|PC;0E@cJu6eci=2?6)vvM9L8J7nOs;xCn=jDdH z6hwn^a?)>}O{zKsvgQIfA>@zG)LG+dO@kJI*3P{Vub3>U#~sL()&!i?jeF)?%C%NiF8vOF^eVj02atSd#LTx7ziio&4v}iQQmZL+dmyVG#sf5J!TzZ4 zyz8vdYNsB@lkQS~#O1e>o368J)!B9~sb1$+Pd^u-t8gLVq~PX7)_RY3fo2|@yUcPs zoL8ALV!x3QTy>*mnBJ?yscTkP4UU9sbUftdQs7;dtb`N61Cx??RCM?%>!;uEclk2! z6MP$XA((0B$G$pK)Z>+dg^u{H)C@a$4uF<-Eoj-O6@cy1RAVg*o7=oo<2}ynOu4Mm z$WUhh(m0ITrYmuD!tK@t-51$eN9*heX){18^)5E0+lP*xj`dRgK5i85&B9lMR^4F@ z?#f=lHsC#oCcYjQRDBLjHZPf)EJT#Pi0Jha=!N4TH$LD>k<;(A26+D`OkeO$TxM|X zoz@G^+FuSQbye*L?i`CbIM6aV{Z9nomgPHd=!j&GG@Ke=CR;k;%gNUvi4Mb%=DX2% zAC{8URzX6WzAKAYTRF}{pU8cyt+dWG#0mSS&4&zZHnnfH_ek zj*h9y#<89H+Bo9(e$vu1eoyE~xqzt-F}madET%^CTNLpyk@iBUKptJ*=}2cgldn!+ zhIH~L4RLybR>yylpjiIEdXOdJT!*QEb$}g!Lx9dWtASodlkdWUEUTpBuSG4;?!p3X zq{z=k#UHR2aOrzE2__$icTvm=BoLVnV8~l2J29rrPUA#G7u*dv)|Jhx=^1th==!6D zVzN*H&PcLk!yH$pn%4(-{)ANai1!6@k-}V@ypc1jx*c2QSOv`mmoeYiM^=!Qd9-8; zu^i6HA@Ok$_;Y}dR6{eC&naoLO>5@~sE@;t8AYuEQFOtFA_``=(L%9F-8c(_dHHij z?L3=+on;g%8$cR1eLePvMG7_U-vuEeGSx&$_9ilBjxKPd`0urR7e0^uV@w_xk?neW zPgy*0S|RMmq@&Aa$Z>+jP|4q8A0u)70W6;Np^RstP8$UuCoAnb%uXVjVsDP9?qF%T z*DB6E)h1zXHu4CZ;;|o~wFDHl7F4dW$~uq4B?~MC=;SzD_m>@OtfIh(2sAy&qd0zq z9CH9#HM_C3mMnTi;NIkR+lcsT#K~6Ysg6oN8}Z0C7!gVjgfk4W3ABvh71I;D3K(jp zsZmVb?c^DNJf!FEW9$!(6!I;^BZa7M4zxww5tZR4#N)w83$Pe*YNAgBZkCPf2OQHl zt0XLlqTJA$4_D;rK@EjfoU* zb5#7%sQ7(|Q#6(qX#`6o^FEBSr84(EDW+83$0)0VtNclBmY1fE)nb$_iY zPt7%?e!bPACWCSE}GV|#G_LwMq<1Q;bV92DMR&@+rPpg6vIm~hnn{o$n8nhp2w^a{q%f_+86}j z$VAKIkL|6*L`$+YvZbX5Uj91ii4^I7)YVN^Z?pzG*W-neF#CfWt%rJ37!Fiq1yfT$ zvf?b~Mj+S_p($fSJ)TRyDj(J3Ci;)k^a1MD@o{Uks(o*n@wio$+6z|6novI7dc7ro zlZ7+fAGh#v8B;Fc4#b{MSSSA{;@?UP%cw9-Q<_$tGb*5DJDl`s9Dvij2J6UrE2a$Buo|7{^>olX9FMB_j}`(d1YFCH zjRUG(@ESI=gms>o%DFO2;dsY&47O>aRH9|%*lSiVeBA>$X?Pl)b?i2)ud2On71D+^ zAS<_7YgDop9;so0v!!IaRS8#Fx83rolV#|aC?=UOhpw7(p3-nK`r5(m*7Xp1?(0^u zVjStpF4kG3;dK~&>%D%GSbw)Bs9mBdpkWbY%_^tLtiM}+wHA=hq|ir(Ofq#yRXjdm7{;hQaSms{+vxy^VHoSfF{G|U*E8Nfm?0wO0>FpN60M5 ztql3L-$`HfJLxt5A-y-2SYN!tl`K-{x4(AdeV%MG-p5k$Bk5frWs9~Jh<$RI$#?(0 z9IKBjBrJz!F2|9mmk)-&1(T)_-DK`t7|KJJEtk78lkYjMT=o9IpN>QGAUDZ+8}m`- z)}}%`&^4qvvxfIZ2titnUjsbT|BR64Pj?^I0??AYg=ZINXS->3UlSOyZAqCN5hF-+@=+Z zqVUUiJFNlA9dM;B7eMkVO)iD+W0RGdz|BRl`+YoP?j?yIU@iY|_DpEz2iD-+2cV;5 zWK#1igi`@*Tr$%5SEb^=0;#C4J{tvAx{N z3gSMpa+GFB#7y+0y`L!M4*oBevEZMuuDmH0C1;L!%m>ncP0%mR9!pcu9fAWUo(3?N8GKbQDk)k9- z5Y9_+6FIe$AqKKmTI&)$9-=WwaEmnOqo&aX|jnVG2>xx~eL{qo`GRxkBR zf?Cd$@;(@zvc9keIO?VR3v9)F91m!=d;7@hFRU(|uR~S%V+ZABtIg~Ht+Mk0vi}Rz z#*$8Zt&5@IqN)B`O`FP--M*1D zTaI}YDIY+8lz^2`I+Ae!)|o~~)%LNkSq)lOFMwNpCTi?H>sB?(bV=Ry@dfIk*Ar0V zKioZK>o7CL`SdXvaX(H)toR0x*y$YTYG~N>nc5!`ukPsyBHlY#@GnfP9M?(NkLcwO%eo(NqyNUgt$BgW zm`6|@`XmC4lp!sGc*1#rivgDbt^nK!AbthlcKce>>hLcoz>_z5(Q=?+IHeI8U3N_M_GQPc{E@7l z?h3e6u7o{MPaC4s*DJGz`UelvlS{NsiW+p6906zlw3FONGe*$a)ybDN_D)=>X zIo$qZveM)BCji;nECR2W=SY^l9(U-Iw6W4W1!wa0_qvnpLQB2wWzHuMAflf!YY=%aqa>P{dV&d#N)~C zS+e6~)mYW>c4Otr%6NB?8q$?^rSf|`nfxx^eX^;zO7-)xnclFiNm+thB2vWJ!QCU7 zev^ZrZjatl)WJPNeH)o#SyFQl)4?-vy6>QAiGhH)7 zPLw!M)AYW_qc(i0vH-PpCc7tq0mk%o&Zqe*SenFkbYF}2^OkjV*MzGPU+XXO$>}NX zZg!`rPI1pw-#63s9w3dKpx&OczmvNJvgD_@LvQQG3ux<6MnoqmPDKOulv%0naY%rL z=3zI`M+mfyrn&QypMf&yWGFdnkR!!u?kc5ls!12zTk6x?C1E?DduY|5%jYgr$G_@s z+nTG&r;Mluf#Qi)iQu`z=Y9pXs7ZJG+9@%Z?k;Et9T~hvg7*X`?4g!(4pVcDJKE*{8oh}P3^^3=DQ#Bm+hp9-! zlKy}C=aFap?tAbmX?ZtyKw0`|+1brqtkwmi{di9>4plO=qCYCz-Am;eEY;cW-I2E0 zjwRjO-F=$vs+!Jrg}%KSc8C5PcTRv_oEcdmDoR(V3-Fw7sgT$IJK(k%%k4?{=K9+c zaZK{T9Cy4rzNXXv;q6Pnqbjntxt-RXyI(2HfwIF$SX6eKCBcVl!f<4 zXgIZyCMyGAH1t%d?qnC~83|Ly(M^1btOPYpxUX#NWbd(Fkk!TZH0{$*4i(#jP?ah= zdnx``^@1P3*xUL5D{Xq}<_7$b&uER-O&m1H?@?p*v0$6pZ zE*ze3L5>-lR&FqW6r$HwvJ9ExOfQU_l*!H#yC|y7-Q6pmho~dVxzekP-3N+2ql?W^ zCq`Jg@?aPHJZ+xRuxs27YN?b6dN1WbtShxAVbdkn*5DlAPGxqQjOl7u8Jw>6Am2;j zQtw9AbO!@(b|T5PF&Q+*$VsHYN~EY81dtw@(G3k+x0eytTy&NM3v_FAcnDkX%dB)` z_n8DG^@`M&*~R+%4wZ>TK_MEUai^IX*iM7L7NiX7VOI{!<9<3`Ke(|#z@z>sI7{l{&qnrr=Zk7i&myA4XFb{anM%;{xk z>&7>h$&zsI=V{=!GNNJ$P*i^kFCa{haEDBVCtUp5IDUWP+X^%FyTUP&MmBMM z?C^d;biVr7aVTJ_#s=AQ3QB*26!*24 zTd&E+zV@(F@_|qaV8z{ySq_6tiJN-F0*vn{KLiWFRN&``N`&)wAprbW;!Xv)g#J%03Mp&JHs6G`rgA06Im0 zxL|4(_CuUzx5;<`om5k|1|x_Spbudr*aRM}er8@XP#pKj09e1?^y;UexHJj3pz$M&X@nVPa*)}LWl zbc{BIVeIAcAxR1t zH_!LC*U_R?+N)8vTk+E3>@8!f>_MIqudT8-dqS=rU{`0*lJbeJ2qnSFA8~W{0Qk$!;8JkCiv>RN0a_%I<=huV;bFE)w7WKLE+-8p2xQ%DS|qBzBm(X8b)W z(VENPjOXi1OGbfohxyb5*t7wdeZ?qxQ4T4*?j>H-^lF8UItIuG$_OTh|7T zwomVukLa|EDDM_)P`@cf8dECTxd5up#Q-MNsE$jZ9eT{~j>fq~k!j5``TQLFbljfd zA7i)228@FBi3Ju$CF}7Wy8HS>EOX(%`^IAH!E#PrOpQv4w@*$8- z6?sGI)>~Xevu&JxGiCwzpur%t2fb?n4+4yzc_(=|#vT3UIo;9jll`s$J|Aj>D@QI) zY%MQLPt2FZ33eOZaA;$RKrN*3YVM&EU^LkWqDf;$7@6VoWc38QxMMbc76MqF3P5W} zbS7nFT_U?CKt7J7o(G$hC&lO48{w*0ioW@Q^X!?ve@7um~OvFYmwV6TM+^mD9Gp9eYbyU1>b0<@>v6Jl%plBxEo87AX#i1R*r zLZsYAwoe6*8>D`!ovT%e%|~NZ@=rs*c!N|=!ysxIILi#y|A51*rrGm!gH2Wll&5ZP z_0*lV{D^VTzD%EFI_rBerjbJ=0;L8Ne?LmJRgF z!kPBPAiR5~*Oqq-$L@8h7rTUWwMBB@U6^E9bE$o%R%c`Uj>!!Ahi+BcR4 zGvUheS$0v+SRpb85g~#_R&p9aK4DRP0AkX&z-l9fv+XxQegAB%Ib+W~9NzjewBN~6 zahW|Kum>43y~(G5F&$70pvqFw{)KR=1_floJK;AKis4^);gj*(^hT(xd}uwsM7W82 zDcsR<_a?NE^vmsz`eSt-?f>OO-HWtofte|i_zEPb2Zjt;>;NE(i2$@5=D<&}-X8lVdxuUE{&O?otm_obFDD2)91e4%vK2YT3{iEqjsT}o zwxr2&q+d^t@}DLs$6Yyf6sT;+qD1{y7^r)%M6aCsj@7|DY4xLHZZcHBQ7?7NR0ST9 zXmnERl~i7Z4_{#ljDgCo_k1n<0+X9BUuAb5$tuz)3dk8TTFrz}!;p#=voAJWde5~> z&tP&0(Oi+cK>*qaBTPeSt`NOZp#iT0fZ}2PXd#$) z=F@4CRFk!MZWAV(C|%O=QH(&7o1ip01(;|QB>AGunIAsnF$GZ@_cIIj}-=FGR#02Uts(7x=WLMTVS)Bb1a*afZ|~X7T8%jvj#f{*p2ED zV&((LEOprEVJ`4YDd>uXFqRs;Bl>Ct0WU51cFn|rASC1M#0=lwc*(!g&P<4^m6NZH zSS{>t#i?FdO6lG(nW3qg24Essp>VD44ezdWOQ#NarmS79`gPoe83JL znNa-&>}&VciAoPF*>NNvk$yWO7D&-zaC@`V+GyX3m8pdu9ub9*-}78 zXoHpjsL<>~aY+IN!(JN>>3AwGOOGfR#Lmj=GGmE7L43nY~S} zT4tXLq8qPAnpa(~e^)HGs~bhbS87H(dVM(k<#wIEUCT&%utz;v_S}Gh1v7%(-ElYw zX!0_A4R|YHw`)sQ=zWWW%?m z)ZK(Jsws6^!k$ujBR=n(DeGohSs8|m4nb%qK%&&gVSF^OH3k+=Oa7OKOlHUW@QbV7j;=8v&XH;?r*R3^x2bOJ4vQFKchcyo1pPW`s{W zz+}MdQg^exy&xYyjgZL84FC$7^+~5M+i$^g7pgt0QZ1mRRJO)~39>KlO8ZQ3GpF6_kOS5tdI1Ilm=;TsGvzwE1irvGZ;dKjR^xj{ zBv!CtNtR4qV`o$5T3Y_Z;FCXPCgekCX;OJRre{)Q(e0QmtL&=uP2e;d$^3w{Z zO(zoPWBR6)8<}ASO951h>l@@1A3jG;yue2sQ;)bzc~I=<*@tIib=BRGEo-aq*5A0$#$kf)Zuso9CP zOpgW@CH~G{(J@*slyI!9SXuuPTKPYAoYgHFm%<)&9Q-%o-&q15p_;yXpWQh~8)*MiMBK}f$KUS1+NN-E(g>IHZE?7YZN#&D? z;SleXik1)9?RD#P+xberL&mXo= za7%Wj)lt^rvTS`?h6O%pWjcXx@*AGM-}#6=L)T3cTpS$?v_gPJmzqcIvHHyUYP zw;1=z822?X?(^Yh7D@q>Re4PK_h@2BpQf7Oe16yw-q{ZS%1Fc~fXKWULa(EJijCN} zuJNe`5Bx_y{Zm4h0Iv_DoMf`yX-j z7m0TUm;@)mFItgX!p-i6`SL@2;u`$7ahwPXAQ{lIg}nW^Juuk!&Cw%?Puv0Cdl25_ zg?f+;DEgqGA%t^9;=gKWxCloz+>E0TR^a%Bb8x=ID`BgLJw;AvjLx4ZWJ?`RkS)>)-M%1?#?h6BY*Q9pS~gq2+`_Az&ha zF*^XXG16bOtWxnmX)n@a+$vf3q`gxAER(XQ>|wfXNs+Dl(4koKl>J-Xn`$loe#yC^ zp-}yy{aMg`+Tzi6^#&iK(-7679Cn3Ty_bkY?_gBCqHjSg_bJ4X+dDBaWHYNUKPKmlDE z($O>D72Z$GpBL+CFW@)f;J@XH+^{&vkv=)iqeVfT0m7`v%uOuE9NU4(E;`$W09oY2 z$o&zykvN-vHK;s33M(3^R5d{fJda`VJX!m^z0y}3C!ba%VeIiB7Ekm)7xPJz|7eef zmDv18ySKIyWYZK5=?wrqW~E3P{-{4%m%pGV#OA+X``bo;qmEvg6uoJ8xU}qpuLUQV z#jDt&zXq@S6swO&(UCe{S@iT4tQ+4T6)$?zbE9PCi+bTy=}Ve}*)MrJ1kM$C$sU%@ z`;Pfg16;->EkF^(2T|>98F$XlAM#$8E&#e?HnZjSCAknj*|7S*n2$dx%y97h+G>N zeDSF~dE-xZXFb%R0+68L0n9h%OIp8bZ`B{;b=nf}W0%2~?>TKkiLc>vv2Spqe77$V zhf02ItI#d4V}OB?;QBW(Y8Vnq-Dam+)=-WfcH@xFhBvXY0>iT2Z((tQW(wC$y=@;t z(1gEYuL&EEI-qubdx0k_6EKnq|esn(`+}a&WKHssEp?Qnmv3u+3*?|bj2T<7O z0mcIs0$BC(0QA=xmtF7JGulsr^L)T?KqkNp|2W7{(l8izr5iDIMKH^qEjOdEl2Se_ zct#rpXsn>C&sBbh4Qn_-F6yv`N#GyYcro-{tXfTz)Hg91JF37@8O&ubKt6yxvK{ux z>UW!KBWLf#{)fZ{d2y#bz9Y;0Y#`?Y7|}GnZSmW%o**^bFhx1)@0fF(Clmf|&(^Ba zRT@sk+wGVlvEve-VJ`(M=Iy zTC{I+c|n5edO{Yreq3=SW<2sf#wZ33RtGuzWBW-Dso`U9uo-P5=35&= z+y0432-J7fEo==Njgz!@j7>_Dk9J|Id;D%JUmPjBcH6}T(Kd$#!=jxDV4Kc7Zjho+ z?egP%FsS{sSyS`nr}o20dgW){qWPR+Ul!b*2Vxqfc!7>F)!q!O?^CXO$x!VfMksed+x; zWiTn2+7};hW?3qD;0`6TrX-{d$p$XzPzT!shi|(1+~OTONIf<@jPU%(zw!G~)_-mL z&zkHFE23FWgdbTmsGoVK5K>Ky-wQGQ``aaTpFP7J4MWRL@xpepbf0~i932A%T=HhT zGHSce_P6Q;1U`cSx@?Sk@5dJ_3co<+?#DKgr6?qdY8ZgFjqwnwpJQ=}o;o!NXI_no z!%D`Bah6%(H}(`wsHHUQLp8{0i(BzB@4>&9$Ka|&AgbV|zu?ZfZ?HAu4P0aAeK|Tu zhJTC2R%9UqsT2Uh{K0U_qHpa<8PP0J3yJ^(WNQWP*=u>gUaS)xiQS3#c1kKE<;Y^L z);r+s&>Sgo^>$gzjf0i-Sofo`nWpSMgaraV@m~;E6#0DBS$5ZB-FX)vP*0foB!FSA zb9f=uY2SJKQ9DcRcUY4Y&8(3h-_4SMKaO!z4uDN9@u)$J(+2=iMA{WUep5M7xVlXtZDxer#!16`+~RlibDz@p zYEZ=a0Mbm6;RjKcFYmWiqnw#ypg@dZs_>gnX8`?izWD|mHu35~yPZRPrnf=%9>hjf zBcvfbs-RpZ|6pHy7PCm8!jmL>6UY$vj4`1iJ{}HG~M{I zab{i32e4P-F z)qi&U4(keS=TceuBkUxWum6bM2U+^s$LVKiwa?siD8zBYZ=LwpX@T3b&E>o_s$ySry18xi|ILRklu&9K4um+k?@VW5sNiZ2B2HQ^;?3-DQ!ZKYQEC$Apr8!Bz%jxBRd@ z>@1>CHU)rb0P@F4PpYaBLkWH}oNXOD=VKtE{&)jTKjA!YJB;rZU8Me3{V_ZDNYwTL zQ~C6aHx4VntYa5he+1p+=s9qbsg?al@F`D!E0NS+y=|ebr0iFF*cs$CmY1>3@d7+u zbRakr5a#chU!(c6|6>QNT3PWQ`vZug=BT|~Zro&@sqY}6E{3bDt@Z8+xT`IERspO< z!95S?9>?BbgMA&WkcO#^<{|yU9Sm1L-{aPogaNZPIYAaLfs^< z`2b`^mj(5LRi0v-DK+=S=ia$SwHd%9=xu;ij?oPnR=ZLFi*7vTSeb28<=7@DslEdp zheS(d7xaz_CuBKh*#_%v++s^Ew7Q659De~qO^SgFC<-(>~6uS-6K z*vz1gg*Un4Z)S?zkos4cxUIzdCqNaTMX>HKxoxRJtk!&J0^$5-5d=zOE0!%lz8-D8|_s*d_J5Jq=h5AwZmvqJGD7o=!SlcXMlV7%A zlqRK+4^UG7YJ8D&+J{xSCLjG{^8vh;;!jXnO)^80;mpuj1+N*GR>0z93M|Kb0Qn}+ zUzZimZGbv;xdE3OOurA;XB>SvKCKC1$~R2-g9KF^pqQB!y;%%{z2Ed>y$%ZklNI=# z51?|;pLoIcfrU~!H`y_Do$q@ega9nJKHfLX=%I_B4*=9zVNs|#8 zAZjTY)_&o&fn#iSDmu0+Z55t&WRwDckxeAJ)Y&SxJ@tlCq~0_|v6TuRy;Fu@CPs@u zG!`8xb&;`3g?Er@esFzLe3tKA^lyuC59TM+aqSbSv#lSe2Q2AEIU{2*ZY?d6Oh;Ae zHQQ7SmS2P+neC{eKqkDHFtw9f$XvgV&)23lG0dm{-y}f>O_MVezYR%)N6t=!L%b>g zo?bd}6EXT7TY1S~SS?epff5gWJHCxR4uSciZsr4M6K&ajc3kd|*ytp!qvK6AG^)wk zNPnZ+EC7?oE|Qw0ayi=5$IT8*Qll|`4koGjg*^Gn2UKbRNfsmQGwOb?NWCL6 z2@~18nIIWry}ivaq}znxstc4pbF~UVIC&n;M0zY6`0`VQ&P$h6Y*;;Tk5B0)l%y#b zq^`=)rN>a7o(>j&?A0C`}!m}udeR{sh%gYHOIO3xc=Kj4_^MQa`= zhlBfarDZD&Vun74dtF*SpO|(zOUf8OQxeP$W0)G#oSV$EP#AX@fcc}F5~Q1)8h4}! zq<(FDDYie9w^qd$Qnn`BR7j)4M&?EE)2*A;_|P7vK!r6jU^Qde8Fwb#l6oz!ryl7w z=@cKUPa%MeGDFm?p|bj!1T~m?Yi{t~`M9qP%PTuF_cnr= zBj(<0Hzjk7eyqQk5#7*7bV(w|=oHAbY*ltjlkOx~<--K1tAhcQ1%U~K`9(x%b&oCbiTypq2o1CO7k!bF@-_3)zm_h z@>Iy`HYqxf21uNNxd&fy&b{xb-Qlr7BS2gZY>V3V_ytY*9R6VKh0K+Ej>s?mRhCsOCoxq*fKFG~AoFu1IYiiTJwG7}cU0u*Kjr zApFujKBMET`LsLWTo(chl9i5D4l@U#+>ZQ33qlN5-dHLf;g>EotDRCTU8@e@B74%H zxS1}Cp-~K3*-;JiO-|Gs9}_8_nnYQAzMYdZ1w~Q?Hy^_?!!N?5>-lysYpT?AQUPn4 z?Czu{q4(^aVl|;yRisd_$Y4GoL8`ySa5#29mnq$_^sy-}*O}(ogf2KwMEQM{IF0Hx zJ5#!MR>?ivAdJdDbk<2eIx2osOZnUABe}d-W_MO)8OtCdT0~ZcnE)@f&Z@f6Mq7%X zLE$=_Ria7*mmmw|aj+K@J<5Prq>Ufqg;Uu|@VfwD%p@gE4Wrv=085xaO)z+-Jc;X- zPGVRsa1M!@l@IR4J79NEaOR7n0tkYPr7e zl8mLufuLZrNCjwmnVhjW{{tKs9=xu?Zx6a>HMO2XVR zX;v1p!U8rHp}F`tTcNx1w_>VefJ)LjkMVas=46scBzE&CQdp+4F^gDHriOQ8{z!od zMzji^lpGl$b1YlklVGitCB3l%--riUX)GQ&RHnl7n>f(CS7KJjh%N$?35^F(B2?ut z+gyHEhBF;8qFLQTpYXV?hpN$L=zl}QJ0&vI6ZRWbxtGe-rzv(qdQ6|n*If69szW7+ z76K~`;|!3Uz0@K-QIjQOd#msVhHP2cTOArV9kq)YiM~}X4(`qX3&5sg25?M~J_Yx5 z02v}4!)L~Z%jPTNiltY%>Wtg*CY7rSEOC}{H31(Q>&sE4_o9f54v`2MpdTg6;^I5j zk1EQlN}Dnp2}a`?raB;uahY>6c3CWA@B`!hBb;B}Jc14fu1;(Ya7=rq6OwhGsmcH~ zfD$J^wLoE&BF~1GV*EyyG#^)-AQ|#`r58RKzqbLXWy~)h(!UDfhW4d!ccMlc>CcsQ z{Zv+99&k>?!_{6IhR*abod}t0P7*%<1mPv#`kH`+HQCu9oDZO?4g-t>a25GwfQ5jY z0Cxc%20RVmy4Y_3iBLD*V9OJwc>yi&Q=S4?2)GHr^CZ^;D6j?1GczV4@oSqwpg|}F z@cB#3!p4{2W@Eq-<(pEXMuzuAmTW*Uh0Ew*p~YGceK3AEM(36~t=|*_%Wfe!F(^hi zI=~;qb(fskS=0=-oje@F@pO*`a>&Y903iLvP3iYK?v5)~4o12zHd51-Buh??5;!@^ z(vzbsYl32Su}b$dRM&CQ#)4+f6byt)W{p8tUuOv{s!J`8IL78p}#8Cd+^|^ z%i%_#&{!Qqsl~S3l0`^}_1~0zt;bhW?cCj8Rh}O$A!=u|1em>OcRJi8WBiCuDXs9N z#AJ_gGrv;#FY+Ou%vvV^wU$vxg3)e5G?RqUZdyKy#&G|$w@#OC#@zw;OuP*X@p1^s zoOLruH4+z4SW!rdT$yA|G`8tv;TFU*dJryKY)CCCpipSG3p})yP0%8{Uk#;Oo1pBf zQl%HhQo5}fM)Q#hWn=Pu1@ahOf)~S0CWinFv!q)PzM=Eg0jdXjjz0`g!*IA=#X#i` z-8e|SWBFELJh05k#OIINAsDQ4h{cDQqS#4}@~D+{2nJSYh??|YE)yyrs(2j8YeQ8H z)-e(?#eS9Vx zC1#StPgY&iz?&ILec#q6Bh{Ihv%IS}R;%j|Sf&vfpsd$Tmhl)kYXB-0#ea|#Dg zBV^mkv~yMX;9sa8exiiJv&uWpRot_(|6Db@*&|Z(BUHlpw~SNaW9oX#L*u+Idv~dP zH!e%xC3{?^q++}((xqpz&irIXsPpWcMdQ6`56z?BWu*!WCY<)Z@tRkA0w!^A(AxwR zUencA)=f})iIkov-!VaPhjIM`6<*L)BGb-OMa^c8E5(l`kP~|OJk=q*?<-68p0A4a zU2)k!DguySqj8tw_qBlWfGhxu-I3uFJ%Nms%@b9YHVnNH!csE@oPpm|2IJ0@EvF~s z`d0i$?!PiIM+zr-;?)J8E8{1rb9Jr23CxpJwKYTY_)~MdTJF#f;4=U63fjf3=y&ZZ-YfwNN#6JZ|Vj=33NTKh3 z4(3>IP{WlpQ`EUS!RQZrX)+tP0S=(Vj|Z$|d}tSFuZ(*zew#LAgDkoTGmfb47hw{C zD$6F3WlYOP%V8RHeZ?BSVog<3bSa!Ji>AV6M!w(4=8L@VaVMdWI8FV&Srwd()WRjF zbv*R>Ga0$eR(;2yjgC(`K4x+|>Qz|}GL+ujU!9MDPu7Jx~y z&}nk$=JSV`IDdzm$r~Kv9ge~2gd1>8IBAT88?Un?30>DrLN^16jPRN5g&X%7a8q1{ z(NsyDrE)VX(Ya;CXW!2R9sQ3~%~A{92S9EOu4~QzQeK~>ZV|T{cd+!|qEt_E#$2=2 zc@CGfj=-g(?_$%=G`J}=vl7zShFP+9w#prnk9CO5tjQREPlTW0aTPw;l1DP+kHTZU zUk*H4#|-hO;Aq*L%die;s1#qOipC9$xqUe)YHt;j;PXpVG9O@xWOVoNVYrzj)xyZ& z8(DW5W=^KbE~L;i7mFc@!ET4aaJYyPZuXL*B}lpaBxRSQmhF+@cn#Q!Ws=e9t%RG| zOa_n|v$r4y=Mk)fG@|G&WutLR*U@=aS}QgKRO5T0K;p6cyimh&L2K7FiLi0G8B0?&MlkQvVx# zxPJFam7TE`T(BAL03aEXohHL^HT=jb{EVgezfBqE4j^TD?oq5Yp7j(KK)-*bYLoK2 z=)`4pt(%p?L@9q}*^<($RBp=uG{Hg+YW{%LfPJr0X}<4fTr3%3NH~0(&m@)Bash+FC>$TcTV4fV0tuN>yTwl3cvFKEE%%IaMoCcB}xsJA9!j~cD3@$ee>`Mc|_|#7= zQCW92dP|Ba`sK^3RhtYanm3>o1CnGb^5)!cIFLj0(AixerB`E-lultzk0d2eU!%eY zh387@d{u@uh?VnIQ3}_;^I?t$NbP)8DnkpbY{_{VtEKnd3I2A>SIL^`9N9fz4am*a!UT$N|tE0Y$eK`Gr};f{%L|5I2ud-xj|GD^MK_$|Zn6IjK3QnNr+rhJG2 zWFs17J=-Eh){a2{(|%BB$Muu?&#;eR$F-`B^c7@fJpZ{1ksnsJV#!^o79HCFv`~d_ zy2`-OHu$`hD0Pd}j078)MY1&>U-n)P`N55?KQhbbU%W6tW0CrSpN3sFTVOv?Z9JTwC5bkT8xJ;ed&(sGh z7!gbvF`qPhECJ(BLq?+7ExVSX-;gW~%ha$8GQq~#gpy64OuAkj0h?Rj!%qJ>%T=3Z zIb#Pc!db(BX>d|t|65zq)QVXT$e`b-*I?`a{}`@r4@R3LWW_5ET|b9-*&Bp+6(BBH zhZ9#8&a{(*FF&0uLszJCPtj$JFbY%GWxTb7nkm;~(yLpccBVWOowT-@(bmv7^ z@Q$VB3$8vDt79L89{ks~afk$NR%QL(0zZcUB``YI0^SDj;M`7tI{@_nKFp)(N^@=^ zPHIOa=Kw-Z>$s)t`dXpkJe4Rv$WZAf{vtiH{Y1H$f574p+< z>f*NSBt;wAM?gj!N@=)V<+i1*XMX6#YEkI@PLcJiRB;J|jfKd^ZyG!DPHi^LM7XjZ zTBR!VA*j>_22}yDhW$3w%*m@&RVEqH3FB?dUWGPWnex_Z*n}?f!D@v&d=O48p+z6; zy>Z)(pj~9M&8Wx%ZanCHyPA};u920K+f}tpT&2>SM;m1mwkY=wuLN*Q@EvNG)|XuI zuTjOBk;3rE$KjoiqXp*TUcjR(aRc1FvS^K(kg^M1J?d<@VcWF^jlio?8AM~TQNMh5 z{mM(2GI4;0YUjJwbG#f>J(^8o0uW3Rp5YFxQDaluHBAQ1D3b9Vz{<9u>gD^#kw`k| z+}??gW+^h`PF37oW0Z-;2um7vBbYZ?^!T%bjZ}AGt%QojJq>XXn7Sg?}YovfawcGBom52?{qSC$;pK*iRC*%)X)*|}DgmJpqFoT}Fg zz-S~zfiMcus{q)~_*bmDb4#%t@xXr)+_+@y#;A@@%f#f%{ZZ`jbs4Mr1^D!I)1qL1}h! z|LG=Z5lTh~&on{7wr7<5U)(m*@iPka^xl3Pgr zKdc;WZaV7bY1PxX8ua>)Fu8F{C;{gF0hKm@ddcjP2pU>5c9W zDy7flDM0{vqYBdigN+t9N%ezR`aqh+5`0jV`JThH*^S9LFe$qqL^rC7#66^nGFXur z2U%?KiD}lP;vrR<&IZ(EJ8UrKBSufM%+$yZm4clxvKaDMq(bxnFg&ar+aFTJL!*Ub za@+wZOo2I$mJ9`WK7eJ-`uRLaQ(A5d{q-b+v`B+^Ool?%SEH6?5dDupXE`uPCn2>R zFu?!hVWk2b@Y6q9*lbz-01BLPAWKY+xO^L1#A@M#J0CzPaO_U^xd67Ed{||SPJk=z z=3Fkb2qBKrH=mIK@_rtGn!r*f<1c{m=48Xn7~@06JHcH9m?oQ(VPijf1arglq~Q^K z#$it`PKqB@<>Po(0kdP+*Crh90svVg2Lk|P)2wA=bY_jz8ILLzopNh==27(!5}UBz zo5LO%+P+@R2w$kf)JUDNC`78o78$-l`Sq7B6HLM;_(dI@6U`gbGr=zO-yfdfuW&PJ0{+J1I3ic`-~5 z|0^+Vz%<~K%l|ih{#8$7uO<$5Qwdd|i8g4KTN?R#l_9&IP^FP^*c{F_5EtF#%|BTF zL@K~OG@)0iE(OdstA0m76@Y9m0jvf5i4gP;z=&@Xrd>zlxEEEHVkRQPy`I!3(Vy$S z8Q&rn$RZ4@Qz&Y}AV8HY+Kf)oZ)Np4aark1ii*$5&u5A3+^l-1%rrItS`jCp7hYXd zz)^axOnp*?x4q@c?k6#pK71{@!~^G}-S6_0O4F@0X;HtU8+ht8rEMyn9%^UF!lzW% zbdHIs7_1Pmp4}gD3@M&=R)<0p*UwAhmIq(Dm*^A|SsQ2b?0wc3L9`=3@#(Ny# zegKE(j5h(mde55Aa^XYql6k&OMx#}FGW_2FfOekFsUgM)rrXWzjg~#nU@bl^4SC52 zKyx*a7t&4vR7vHtsO&TGGfqme0Ymk4%&BNtkTWQT9Kp zDgsmxvK2i(WcrLAHpt;{^2?_PKzpu``uJW>432J-Depe7M&vOI zTDkEyESKUpWi{()aLOrpzS+OZcYEzFa!X=-TC4uvv^8;15nHtQ)f}&xEG_r=(h9o5 zkCB;=zu|;Y4?42&Y#83r!U+i0HjGi%SqCn!vf-S7iP|%06Yg^y@wV=XpoD)!hiD5^2!#Kd6to&!hvhC zoL+(%d!R>hb1M!vAdcbw4umteltQtTy{HDYD#lNmn^(XZoAmeML#My34*Q%x!GpD+ zNGj`8xgH87$)Y;7+e;--- zE=IZx#;S&Q)emu!caKu?(@xmXS!Fn$=f3ywYv23oZR?>>=mV9MAp53cuJW3HVQzQF zSVx7v{1~mh^O~1(ZK(Ap7~(pw8@E*NR@LqQ3@5W^>OpkY-;%ZSEWdS$)bGW~rg@(# z z*ymv}hC8KL^f^5JFYq>9pRjk}t%M1(X=7ZXocFmJmHrkGXhV+0+x5{WIIi2HCY>;x{YRRm9_{YwqH@bB<8y;ChLpfEb^GRe~Jyce4~{5k==_Cc2clXxF^O$0xz zBSLhltRGB@s2>2eanaR&p{AvO*n~pmS87uFKbm+~f2n$>f7HY~_$5ZHyP9}w?2nsx zC+$_wr2iA%jg_HpFUCoqz?;3PW8zBs3bc1OA)*=lw23#8EGuB-=v;r+1ntOIYFGPc zl+T->{O~nCy+@<$0ZL=pmG4vKCI5=`M&gA4J_cQr(YG{Bo{Zk@bNf_U`WJ|o1e{|z z{a_z9^n3~L#wu65AKrW6-K2~s$c~pWIDdb?8r=RGn1}lSv=UTbLs};-tJ`3~$Ea`A zsp(&VP$R_?`3BROUpMjI^Nkv&?>I5Kvkxduv>r#NU~~I^1T`+T<==wnH%*AveT%$& z+r-;{KutL10K92xpsrf|>*1y;VveZ0-@(oFX^D;rZQ}t|p8h?88mIrm0W~(`pckW2 zJ(WrInC&$M%UBdwF8~wy0a0lCq7tY_0{?E}{X;#p^~WaZmVF2BpPG2j{tj*8A$Uh; z@aIH%0C(B zSe$Y&rdp9kk^$%*074X5|D7dknoxn!C$4=Zy!sAa8&M$c< zpdVQ(@qkeeuD4- zRj$Fz2`k;qcs(gtt3M zc>Cjpv;4_G-tiE;aQ{id^G_09aGdadrk)ob2f>6F#fFE!MMPWD4nS$#57D#Z(I_38 zpw#}NdSBQn)*HDl2EgR$hjzO71UROpCSGUYHE#7Aeo_8YO5h#cVs!D)XuheNj9Lo6 z#vRPmJL0nR^-f)zQ03)OXLO7829;s}`;~?%ra(Eqz!QX9vbIfplD_wLkktJL3-bp{{eN&a z!H}?PX!tcO{5muIIxGA-JNz0RevJsfMuuOb!msM^3yTXH)Nt#ZJIk<|ZjAmvR{uX& z{~xFSkH2$_w*JQdmikS5#bWgO&dt} zbkA+_F~f74e9ZLRtVFChtVEZ>uko0o`os9F;HZvDCZB30Yg;r6IF0Qr_Mza$-X(6E zb3j7VnGGCvdhY?SCuzEL_^HD$J4yKECR~!@obvQJu}R(;h|85ZaZa1`S_CyVn!z}y zwD1aecSd5&9EEXZjQc8EUiqV)X+0)~;+)mi7qTMWDR$=qi$!1SlO7*9nR+>UZ@4)M zWOmkvcE>wemT#UNe6pWj(-!s)pZGNSVw_(&=l3`Tb*g-L;} z5e33h*VEr(+s-z9TT!v+ZHyR~xtqkzAi}$M^7F%qZLs2N^&~f!r5{;xG9JJ4#2-xX zkIcqTexBsfc~luvHB9gm7$0VfQNW{q7|sqn2fHjW`s;C<1ir>uD_=TJpQa+=;jcw9 z%5?_!V_GZ=)1E}9GtTojJTaXJo@{rWqI5=Qc8+;Bz+2yVLY<6wM{!T8tYC&Jb9y{H ze-s`o)$#C1!_b2y`W_dN1Pmfa^oWn>q2)-myHA?}kY5m}4wv4+w+%!LQ^V#lAq+SEfqPdxmH{(+|sW`-A>CTbV zG^ZS2>xQK{D^jin7WIOHx+kG2_yV?kSDBC_i4{&-XibT8x@9d5 z)pc=#HZGf**2@`YT_4)m%h~3pEC)?yP_rU|Go0M?8{lQCEX`dDeZ@e^Z=$_Jb!RwZ zRmzQxVwVkdic(g<%NWypq-Ln&Pq`^NrXVJ6K$(${9NIM0IWsQ(W`uHDfnp7FVV~{H zPPql%X6${B1kQFAWvql(ll)8SaA$4$tsapG-?C*m%&gpItcr?1hPYJ%# z7gvOhb3Vq`*v(fu#qv`RXzQHu&a=Kd?cghweS=4KbPyUYjolZv&?|&-?DR<_TYn_>1KwYh~ z+rkoD2zG|=K{Q}Puo(Xld^zcVl{4Ch&nm0uIjt?rh0*ja8lzxN6kOBn7*%nH4Aoio~UHyBTTT*{LjZLx56Ou%_w-&9W)m=5*M zs4UOqNs@Ixq6M4&jGY~txYTK5^?V8#eE?J*Hv80CW@?(}$M91Cq(*IiOx7(!(_a({ zEpsM?FK@%`Wy9mLLfw};Gc7ITq|n+MocVF#-;#BcQ{?@uyveC`HX6pI{$EaRaB`vw zeRPx4BOKKVrQYJq^>IDKD~qj6nS6JG3O#tMv)IBnSN|$cHPU4GDrdeXnjYG=$_e_Q zC6n%Ora@a|>l$Y)OlIq#GvD__xO^WAI&V9hBIyQxi;nQJ(AwX^qWL!4Qnf!mM~>d< zEO4ImaB3xRm$TOQ6v7TTIaojMjL@mIltm9axzybrom8HTT4O7DOPn;{(_zfePvU%N zS}*p5sH2=IWocId_^{Mp2pxIQ8E*NufKgsf zH~nEJ?YIJY`C;d0--})*QMIOkt;$E8p!JgMeAKD)#Ik<9Q*jp4BUfyjXnL47AM*0w zY9E@tm_%|ob#*ib*f}$XllrLCEoXE`>u1aSGE6(&P?AM;jXy6{GxNWZ(BIv zlb4)!vg#$Lk93*}6Ex=~Cttchf)BneH=&8neA#)}a{hv(nbcd-uoas2$yO)Z+3xwh zO~2mGUp?oJFv|E>fKuoAy`%j?YhH1ljZ0un|691tIgFhmp(U?7SNQa4UhMzUE<~(} z#BFnmtamkX@U-k?nYhjAVC|H^Hc0gEe3gd!zv(>gvx2h!Ek}Isg)@HdcBezU6%1{y zbBcY=`{06wT`To}bLM)50yBXV5#Du1w1npD{M4y*KJd_rB=gE82EK)5*&XH|rXgA0_!d1(-11q^Bo8=>5GR{(5I~IC`b?xrq_V`i?EjGAaMwndIy--ctVy zr18Q*Cp)y`d)Q*gq~W0R0S_bp;NK{_f1!Q)(OClT`X3>G_X`uz%P?YMN$eqKgbaNc zDyqxlz|_PldF~OY?Zls*w|!sP()kx>sPAi#`o-xR<}6EI{>AC+>@(!Z#|mq|ZewKC zVW&+i=8J6-EfTf!n{c}v+Hu%v7Y`!q;@vE*w%>-;wtItf9=umHIR0^_Q67YN9LrIE zjg@0X9Sk7d@qnoSKGEUL#tR*3a8l!tL{gmVXG`$p7YZi}$0sTo73cn{RTu{q#=Cyt z)W*AIVJ0^^2TUeIV-wt!zJBBmUYdjGRENQj+;sxbCh{RC5ge%7Ct0e$cd=pat%S5t%a-olaZbI* z?LD$N-3<)<&U4aGXM4=(UOs*o0r(gunNl3w9RWT7i|u=qdMo!d-$B&a)^1KAGZSs# z8HW#xi1!sl>+q)n0N{#}zx8&uyccW7m%5!x`Wq5%* z&2oM=L?l$`&hY($fn1Th%6AwI#&Ybh-BIMe?)5V=Wz`sH*C!oZ6?&nAd#2?(qANjO zfhh?iaZ^ctjnH1%NBM(C=OxRWPVW84Rcf(YEK9aIU1d%__C?Ow9M?hS{004xyNcb1 zrPZ6Ltz$a77XWi}XSduikiaPPi_N>Jm&_Af!ncYnedQ@3kgG2lQQrgYU?SGMXv1Tc}7nbli8Ggi}K#pR$85>rPfQ{ca_z}m<2M~`Ja}tLGQ-fFREmfnN>1V*r^lZhU z<(yBkB90~?n#G-OH_qKxa5Fle4#1C|sz{1)|KeTKW9TtX=3m3h3YAW>=R-h=O>z!U zOcIxRB#gUCUhD3b`Qm?)e|L9#1+V|8vrH~?)uqc~wy4jHai1UK9sswQMImiUtZNL; zUhhgE!#*XpQR>RDCFmtNQU;^_7s>76=C=Geis8q9kaupww8|WuWPa=hqpNzjGXooN z9qzBVX?DGnGnhMPs-1%M{gC+)E@*9#4daogUudxQTyjtyX`8}~zSbDCoqAe!eM zNC!BX@J1kzqRZ?IsqN_&`Rs%8scq$5SdWF3(ZL_bxYxzF7sa?QfSWv21Nc4%K>jG- zo|4)Nwf#XU@8$a2-iA9=i7^%s&21+fZ3)p%kk!3l6I$2HablOjP;YOrLw#D|pHLkmq^xmm>M<*~I zCx1k{&xmm!`Lc2N-Y@-)1-UZ@;m@JszR=46r{0*O0zh;EmwWipQlj927Ez2*z@buH z6y=xa`58qa?Jse-Ni^;I;PxaerDgA%K&0bAf zxY6nOQw-BzxbUfntw`F5w^G%p60e`pZw3T zyrQ%Dx|gkV8G9N!)_Z07Y3?vAL;BarAd&Wre$~qy*l71AP15u|{v@M`6nBG#i_8g)BPV zEk3*MAB{C*8r-pUuNr>IQBnJOZX;QmqRfBDH>bN@0vkUJC-s{s{A=My?K7Fe&lZ0N zdlZ6UXDVceELDJ+~=uruo$eVI2B-v~Arm#Jw-SJHySf9+l7;?xgmk-VgIc z#ioE)dvB(ff{j|1pKEjU! z(qOz<04^(MT*6EMckdxwzJJllkhd({5OmrfoHTjx5cY^3E=bCjS$ANha$s9hhjjf3 z5$F;2WbaD}gNB?BuM7Y`Tyf6`A65=>kO2;=@Mi89jo~bkLI86^KRstBWoNlKxDe>c z!OcHq`La~_BuN~f*d03zHl2kzqw7CR$}U`oyha!DU2sR6rJEaM@$Zv!63&CaD{G%g z$fX4I=T8nwDWYto!a`}&T7Rh6G2Fe$o3G80@i(Zn;F8VBvTB5Ts`aaE8{u{fpelmh^uVhpHU-0-tBzJqI{B;veJA#ZlhDG43hIH&bC* zoedZRm<9*{3c=uPzzV<51l09bl_(@kaOGYCLbsvk$|@v?TDTkPbbfT>wH0b`t- z>rHd+ALo{*_kwQ$fEvVz=w;+$PvP0)-5za8xD>#V{9I^H3f{!YlbXNbaLP^N-M)6N zuK4XFb)-8<@Sq2yn;Pf`18vs68_mt!BNF&4)D1w;)=E&sE*ogKLn&|p3B_%$j z?gvl+q{`j8!ha3*FA~*>Fqu2i$gYbTL-#KRP5a z4F~JgU748WG71e?drS{lxM2L=3*C7*SSfX~TW)0q%ltT3WU_m@{`AN^QhZeaK8%*< zMSE+qo90cA?w*W}b1ykE86CE4$*pm#k=E8^%!FNEgLw$Qk}D=-hT#1gcY%`+nqdW= zFvYD!tVI{On7Obpd^<1&6DSL0%eBbrOr*p@>?I93xEoQUl_GHcMX1_mOZDrCSv@a9 zI5m0+fQ8P&Z41Z(R08-+0-*9~v1Lo^scwa|nu>!4@`BjA^~qv48OKd*e$dHnNwsEn z*)=Or{0@*o9*pAPr>4PBYS ztgwk-iBPc(Ia57Nlw=)64oq{?A}SJ_WU|z;@Vj?TIuT9-ajv=8ZPU-B)r1cC7z!W{ zL!x+MHmHuhx zs36s;x|L($^C5yUOGa_%XYxoUjY5zSF4Zx`Vk`g|nFe4&x=f^Ex|`cpx8U$XnvH5f zq0~-yOFjF$?nIbHvU9pyRuWB!=7Z@M1DFTuTnA*1Y3r{oSu${j+s^mw5t%Z>Ei8zR zTLm0Gtco4IIN4J3ky|P|W}qkGj>Apd`)0VO58?GPY&|FmQ$3g>G`ff}JZS~RtoWpqvOVaWZ(b|7yV|lk zi+#CU;gpzUL&Gn3r}=y)>ZXO*dwJj!rOuiNf&}*H%v{!gwM8sw|Blf$ojXGE^x;> znCsJ;;mV2yZcPDZ$r`A4RRBJ$u|@|$u0=s`^T;fRHi^Cqq{2!nlC!UMudo(`&|bt@ z9a%?ckZ5440h0m5r?Pej3C61p?OEuiTGn^+!yr%7N=>-yGo{aL-%5*>{09!8_h~6g&?-Lu2{vUcFV*+lQ z0dZ3iKUK-u;6$Woq-7AJJ#;slC|M2=^n%9Z^3 zpi?M2GLlrNr$!2wjMlr49+z-Rw4pVS-N*PK(q z1`{d@?YaS9=(OQY49#BQ2E%JvZ1EpNewXr(D#)4($0 zI5$(=V+&9t(WOSv6(lyzQX_A4*u_oLVeA$i3#-F1TiQD();m`^-R(s&gOPCJh>{zc zdbj(Xg-+PmdtJe6|GjPvUc=Yw*T(QG>37;SJN(-IJ2ya-|8Y0^PE+AkW)(_qw{hy& zy}!4U15~loQ81U`ZM2^!qA=?e3B%9u!a2azIuH}yAK}ES#G9F9(^?9kjh>I?oHPTZ zXZ+g3k9csWYPy}3}~& z2}OvIAWcLFQbdY`5E6)lBql*Xl#8NR5K$wHii%e)BLs4yUUZ1=$1=6uxuKa6-}t#3-NozQGq5nj3N1=k23- z)FAv8xocy1mk2i#3pHdCz7Z#{I^Pqi-V~#11bFvsJ3!&4@T3&VJXl;Q;08I1iKF z53s%AZaL6cuFq4kWB}cVZF26KgCe1?t0oz-0H%B06hG9Bg}N>S!US1`*2y<2NUeG-^Il5mTlo-o{=bw1o3#k5H6gMz6ii03&5JD z-DyuYom>EqNooR}LKGd5*#fQMx2sHQ3W-ak~sWpw)>d^p@L;@WQJ@a_@tXZIEwzF6g4|W(-l8pU56~e53 z)^`@xdc@QIjMHGG&j7I1lmS=~!<{qpv9jA7bg{0}H z+tbh?<6Du6dQJEn{KR0qYEbg4L7~xW?s4op2{c74PL1fwmP7)f7eFtm52*874PxhB{a4Qx)r5 z4=%=Ve&Dz8`0O*?vT^3&%EnHE6@4~9>4KNvnQ@OW!jO_-P6ZH<1<8e+?uM?>r+ttIuup-4P})nynV=Hk=Cl?Z!={VFuvU zb2Oz}05jd@Fmwf2^_N_BZ`;_$Tiy@zvZ=cH*`HtjhrIwKo`t(T4?8I4X9fHV>&m$} z)9S7(7a`2!KgF?amxf`(y9fbxW3IpmYU@xyV0;zgvc`y>DGM-5(kk%9%=t+&|glz?sCm88PY8Au!)RDn_wlYTCsHy};s-G>?ejEUja>F$hWj*~aA*J0(cdAJi` zl^1dHQXPYnMlso#QvvPddeh9uO|&~LbArsV%xHOPggH?R@vVj*wfXw!7hTvtFjFWOw^sdS=P@Wz-U^|S3g zI$0fKjuZ3b_88MA7W)>)nz=%K(3E~mpQ%DNw;NYOxZECR)~JF+PNPw1Ls|h1s`z4{&s>Ht=ELftOT>?a7ss?A!@ir@tJ!-p<=7}Z(tNawc`KY{eWIBJ7uud^+SmR) z@?fGF7t8j?TF3;@N_L+uXKuwETZ6aartqAuriJYNyE^SQOwQ?Q+7D`aWL%PYsd5aD zygkV*^wc^YS0lepG9S)hSHQ+Y{oKl8{o(dSWjdy}@$F1Di|uC)JIcZ<+T^O;b&^q4 zcgSHo#fNA968483iDs8X&TM`zX$QGF)yz)`G%StH!bbu8T;<29X0G~LQWDVNjowca zGW_c*VEk4_m}Ss;h69QkkL-+-gRAk}S4A3(O*uNqb!p}=B26}?n|TiAg>=*FImfX^ znk>$M)kzyAYckBqcF?yw169&oU-hiVEmz4e~bQi8l-i3G!H_O>a(H({Y=q3%)7>NFO zoa{dk-7zmkbd=kHNhC47%k3Fyd^gh&*}eeclR8FDD1h7y#xi53e6_%g)MtgsXI5Z8 zupLLeqXlMi$|AQ)U}7Gwi5I(gS$LB9x#v88G;fgEKVk`@6qo(9|0>MtLFU8Ru6$I2 z{scnBvj}G%tiJPsERx%|VxO{|hx5(BW>`$CFPWG34mMZzy8!gAzU;v`?_m$e;}q;w zF9x`CA>!^uyi8NO`i-YH;>MvubGp71&wLb`v!b3x;6w=+`6A+oFpZaPA~S!Cu$ zRp2@(Mf9Rbrq;;zL(DkaIU0+jD!x5)S9h^%#2XRiMSVJx@-NA8~aB(jNJ;yK^aq?!~ zZq7N)In#R}x%~2w9@R6>LDCmFJEN(2aCXLwoSiL$T{s@?Gv#Y1n^Wb{lg-OgmO$JU zPK8hd*B{wzL642i_19siJA5`@SU=R9u5KW3yKoZ(uCuTgV22o(;pve^nD4w{=4HC7 zg)m>+k?i0UZ(r^yXroSe^eA(sA+NX_g*<*19!|Ptw3+4WImY}1*Z6!Li_N`y&_@xnCYbv|UxY4i_$Ev=r!nj1N#=STmjH{;G&k!Pg{_@p-UaN& zDP}=vtFK(nDKYIA2ne4nF$+ZKDVUnimwRWLL&cN6gi`bNkX8igF56X@U+BvnIXcV% z6YAJOdgqvLw&?(oy6Ez|H^ScW^{h1Svz6B6!Lyy7GD^0cXO4C{-pTV!Ur4LM;eF84 zeGk=|c!vH{h!rJ2KgTTSyaWpk)(7i?Vs~lRwp&Jv~dKE;9w&1NaEc*sc~a!qx3E{=;wLg~2nYr_aB4u<#hn2cZ!PmJ8*#_xLk(t_NH_)A zc+hv9@)XOH{~@caQhyAzvKJ-JTuRbOHVY?8z1uy4YOk1lL{cOjSBc^AdB~K(=}=klB1zgCB+DifJw&4S-~OXhHzPyMM&K z+MN{ne3zJ)>VKo?gv-o_MGub5G(UUmB0wm>HO8^V$-lxhbZ-?h4AeF4JQVsk&N(Qb z;r~bA{o8_Wf*?Ny2$S>wi%>9&(o`0#!o(~~*5DMHfTDCcuX|V?zMHXkm074CHDvr% zW^eI5-aBFzXYYqxu$5XP($CQosV5e2YJq!7w(ry?sbDwAc?<=(BPqvixPi)gr4weH zG{H@$WycuQPXkDod(mJ zHJIE84Kjv9gg_03ARes2BK69*v_8Po_gO9Mk{JHKvFqq&sphRU+lHzx$nq^*XX0H$ z*M!L@Z#FxJUW{Z_; z)>pmWyf0L5RCfgXdf#cj8~RJZ{ZY+;-7si`hk7>`U8X;=NSEe*t$>d}!)_3ER=1;=A9#mOK)d8Hz-5M0XEhxSr zD1LiT{Endbok8)tTE-1+BNoux&7K`LwM@|N#`+m}{hl!2vhC(9G5+2lg8PEv_Xouv z2#RkGif;*%eV#Q>?)spErx#QJvH%Rz8V^CZmDofXdmCQk6u!fZ*B=g(FF$K`)gK8? zN!=R2hk3UJ#eKm!`aK#%@mNs&@qjoRCu{i$Y`pG3`A?!X?=Z)Ac*>!1>+fl3wbRV$ zussO>44!@fzT2}w_#FXpw~U=m8P7TA=biH|=lp_me$hGq%Q?T~oOe6tm!0z~&iPe% z-t*?k80n*Wbrn>6N(FRM|a`g?eJY#@x0TF z=-}4tUU0DcJo}o!MZ3)8?013W(1*#Js{HqyI7bJH`Mwhua`oPjINzaN=7~c8AWU|7 z5lwlYI}MX1FPgb=r-Pp6918fKN9*S04##cmSgre)>6JUSi1`Z~XYIkjiMYjFELLWgs4#p3ZjW|ilFKOyfmb4kbHwtPxJN4Un1K8k5P{889{ z3Nc0C!8HQUE(~fs_)#1=c-#~}rZv8D)`LcL6g`AfW*!_D+RODD+N34W#^VA1Mg2w^ zL;hy5;uRvE__tb1t*??IjZ*CFK%n9l+Getw0FvT-!<`4 zFYN!khOO)a@0!*L=LFIG8+(m`r5*~3`((m<=Dm|X#FdZ}u`xIjuo!STU^9T-mpffy zu@q;#vwi7`@s+b*NjlDgT)JCi!u#02Ivr2;nE5$r4iyzE0`TCBI|smhoe!N3a-PA* ze*bo{f8q7|>GG=U^)6zN^j@z|V7N~<#bQ_08^8kSo*eK#0#k}aKY9>QA=~dWGouax z&E;}4diP(UcqPz2Gi<=eNMnWg(-3xNlumP2tUm#rdzs8;y?LKGGV0S~(8XVf1h3N_ zsjh|H6t*AKt@3B#Tn?BISOB;Ha0y@)U=84Az@32m0b2o20iFlE0(cv+AMh#QTfn~o ze*t(mOaveXkOaVY>*a0x&6te2h|~ej2V4%g1MmRgNx(~hcLATu5B8&VO@l?t0d;`; z0NVi10Q!ReXHe0^InYAg5a*nm>7O4b{fpzIe;I}ir++HotK%^E`Z(#|94GzTFz-KW zc=$LBjvOcbyW^yP&r1paWPu-!lm6pz(tkQmy7%A5A^7AxH&{nvj^_iDfWGlBN| zank=dPC9qp{@%i<|G)l`058=#PI}XE(m7N7I{^eQr?`EX03rJ{e{)lBzK+scM;oo9 zLt00NwvKMoI=byK==Kdpg1Xr(3`r3!g}l~Ch~kCqR%GXPXG=604PuXN1~URKu=`~P zV}T~vbg43LiziN>est~mc-HXgkMW!*p8{xEiuzOu@5pV5Zu;1aYw_i}_Q68PW4>_{ z**Xc|am<6NL>)td&&}KS=5;tGX%EfS5$KkpDT$+7N5`~|<_8m6VG`FmI{p~+=2t`G zsa-2PIv;~>`di`*?q|2)0h4g6A{3Ad;Blk$er6^`C4#i&c)a;DGa;&LFbC=PwZ#ER8=im9c7p|q4bS#S@H|+K4K78sDCl@aMInZI#!Y<#+E&p(l%Hm{Vw{9zVnTm`Z~XS)LNV5OGJBZJx`82@l(KFDrP)UU^M zM-MFje*6o!mU4@Q13`*RIEs5%zdDNh9CFswSa@)_3D@Xz)~vRYVHW&wbO@$Mu5EN(@poKtk^{s8={;PUsVXc&}+N#@s#i1D0R(*ejTBC*7Do3`p z(!?urUR$dM*E&9EYi-1BH_OAU<$A8CF|sN)k;CCK%*Ej+$~1FvCXTncWy=DOHBG$% zsH@GIa#nC2){PM5}2vxx`IAr`6=uZZa$O zSmxW^5Si*D(KqJECnBvUR6J6e-lB}Wr(CNG8* zdpauPeBM!+qkXhBxf$t=whAa{w3Uz3k!Xt<3T zSFt8>yp<^jj>k>>Jv&)_ysU@ipy%FWi^d83#eajp+Ngv{&g`1+DolS|y>^IJ_`-5KuO-S=>3YoYGx0gc#Gr^)<8nC*G_LL%JzdHJJ# zO6sa&qr0LZ!0EbL8$Egc9K}hN?>HB+f9Sgd%(+%s3gEOS5fB3y3OEbEbWYVd_|*c4 z+bKt;SO>*US<)*sNzPbk;c<;rD_-yA;rq~iOH-|3x@Qia+G0klv1UJ>xJ$Qsi3Ktt z1CIAF?!brGi{%oW^fAA#%`-Z8NCqhvP$xiq4yKiOnbh6*dcap1)+P`6*ah$DW-Y;c z{zqrRdHRk+-_H$qS58HOI9RBAE4b^;mehhy?#Z%pqg)hKp8pTwzc9m9?h`?US8LfYZZ53i7X)(00Fdyqm9enk8OMaH+@#$f@d_^%?pc8 z;rft7JURkc4%N$d)XR}?cDKs#+M)hEET6XzuzpEE#fqR`_a(HFMweq+zgE)XoV5O} zq+tr6@|}pZehAa9MeyhQkAz3a89l8qPg`I(zIT@;J*~Wm0U)GRIZWfZ|F`kFr0Qu# zv^)S>u|s~|)7pts-d2$-mxkiu#{+rRX)yzli9SpF(Lf9*`3ifX%ES@5`UEReFYxeV zW?khwCsW&ZTW%{Ssri1}804DYU?jZy)WTXB_n z`Bp*%H~4wjsLA|e=*MkXWILxSlzS?UJB#6TUcm$Adp z0m%SX!bu)kv{9tS>_V74S=~Goz1-Ue-S8k^6Hh%p#y$i^$puj6_nbJlEa+B|0H(3X zr{#oxR)2AsT-nc>;28{?vRPatKksM#BA$>3`&+)KLSS3j94TrYJ*0K?$;Y6R23Uo- zQ?FzIT4@$uGi~MJ^uz$G*fSKgv}2m=IMCXwu2vfI$Uv(}Y>`I_pyC!8cM=9y+H|zU z#mS@|qY>m7#ccF`>Xrha>4qWBM(U>FZBMJLgcQy_MmZ$IgGlJ0snUCrB~RFaAg#$> zb`szKu6~x`%nD!yO$E?qEKQXl`wzBC28{qmr2}gK2a}nF(J273q;Ml!ExGt!k*A;H zSvyN~?(4cCD~EEC6FION$zc@m4ExnXICae)yc%KGAZr-zYc8z9%%shmc<%P;Qw^*# zOe{6J7Fk&^n6fejhH!%{9BGY?C`TIZO;pvpGyUhC`1t0;y~Ueh!m^(;5r$MdXtgr{m3IH6t;r zYbTRtTXF2bw04b!Kg2bjnw=~@lZB_@f!zc9F^L_Yjj!9CDPK4hJx7*oIu$dC=VaPw zjF}VV`q7wv4VE8_w!An^JI(sQX}<+yED7p2$5_P~Sui=<4m&=!TAF4G#45y@2VFVK zH*&0%Bw{w;!ar*)7l3TI9K@$So6Zi4%V2vVTCqSU2M#KZllGQ#bw5fr&Btqc4xbtx zHfAeuq;WTBNtcQzyLo2E$cp4S3P8SeqBD?(IJeWJ2!nycgyZ742vWp26qa0nYj~Wu z6Hu;D!*Gj0AVX#@aB#%CI(2t&u0o{i44jEG>9}J=TH5SS2uvK?mz)1#2Zx4qsvmi` zgLDNV)0MylT4{bzJPmR7H!L7k9z3L{$tzB`;^k-gcsurtaUSe3njvA0YbQnaOLxeU zTymT_AE6FBc&5`108B-h>?6Ar8f=z?r7uyoWx)$|Qb{lRno?mq#XH(lu2Uo`IdAiE{H9Rzj!1p0o`zk&)fe zetd>CGBz-oirC3(w~N?Ll@41@s#1{T_O9skCtGQaFU`U``6pW^i8^_3ven<|y%Ww1 zDwFl!TxRi^R#NuaU`$U_6LFkb4UALgd4Xw-HKo|oJk#parV40FlgmEhhp*1W+GD;) z#!s<&t5Wd|wkcNsse!7nBl4Gua0Y0?O41j2!HF93<`!z30$`j@Lcew6u7|R%DSG+!R4c*DY*dpIyY!^CgnT;KW zo9^}ut+DS4I=3k=a`N8*9F3I>0Lm{ag5;T_3R{d67J44eZu@5e6ov&Weee=aE2(c_ zRmN;zAcg`2!%&Ze-(=;oglqD<$imNC#9lsx=B-c_LXo9VWENWSqhBJ$D z^U*Yv*0m_w!@D9u_j=@O?~2&*%iPjI7HB~hMNuwv(gQ8zHcZwE{+04LDf){%>bn!F z#@sY^^>kCtLdkQv!;=m|8dnu|HdNV-|DC!_r>ud!%f$}QQ-Fu3%utMICjwoDF2TYt zX+kE6M<6D;;{&W?s15DOktsp8|1u=5H%-KiuT?nH%vT`nwp6mF|L~xDQk<1om(H+K zr&0_9aTduQHV#1cY^4-|{y_RGLFXFL<;67D7s-cV@*({y#XnZ+hp{2h?Jg@)4m=+d zlAlYgbg`o`se6L#H`9uac@Cr$_bOy}TMRxwKhrAES9|15Gp%auAeg0A(kN2WA-w>Y zNl{Z^;%Nus>A;-uxp=la;;A5oS9n=pYUM{=jRI*Ow|RGm1Ta$+2@%usSMlC460!cUm7p7=B99E%_9Y%1`4FN zC|VvV!vbQWY&#okqqU%R>mpy4%(gQ720Cjjn6SJ+XLXsf0$h0p%O_@Axnrm%9m9_X zch^yvEm#dMm))Ue3eqWh2!KTnmigt@N-T}Hms=xaNXY_St(5!Yjs18izPiHd;{QpG zlAvT|lNb5q%k>plqfC_BE3CAr>yJtOu>!NQ8;(J5o@2!+Q@HZ6N^T4$LmVorhEwL0 zH&rg21CHy0NhLX^(74o)dXVEy$B=zK$I4H+IT($&TadE9ESQT~<1N8tst}PcSI@O3 zBnA(RTq*OQRgz@WTr0`*t{e4bR$A+XzTPA6`$%-vZ}rGe&bF3@QrswfK?Gljo`?N7 zJ1*N-V}nkgZ(Wa#-@Fen9e-%Pbz&50Tgv#ye5(W`)2dOA6XoaCSc6WLW)1d|R>}S~ z*h|_a=hUEXR>@0iuw%4JZmzNB;gnEoEkuUKT5EGmu*=wWZRj;$!(RR23oX1HbD{N!hpmi9ifp*E#igBwu?MFU5j{IA0S!@l|H+bYXi>-c9wxI(z~iP+5AO72n1-tr{BTjh9;8<$?38BA6p-3HmYGx1B6Z4o~pVjO1;v zq(HEGiM88VMUc>hoRVf6*pG%Eew8ocmDUuvCltaHd|ORW;n_?}#9b>*w@ zKk&k@@&5Z|)?S=GUS{P+&}CUIX#gFK2fK8=FSMq2b@7?NvzO$w%>b}pxD)ewzEXY1 zh1QnvyI@$33@;gS%eS6b4>PcShsu%-VR4P&!|{pwn?fSb;xslHz%GlU#V`Q9n}t^c zh~pSYylZ1VPeR{F0TcmvkdDwBkPaX}ODsQF6GxQ{Rv?Po-mD*FUP+2$;?}9#jep`Ho{&u{Zqu-^NLLG|5`{$-! zYIX5E20HdKMTllA0C4 zW)0!-=G^v|TXWPKjXd6a~BIx5|PMxs>A;!5=|xmtv#$-&s&mS;pl09GMA zmeZ7>`0l)wlsFGTwir4otA|=rBl2z|+h2(mcE+QgNDpnJw3dZeVt|Q~^RBegvYB%v zDFN)oS-@;S0$>z?cvYbEF16wY3`f)z(k;+!x>VjB03d@>iY&u7nx24WXW}_ao@qAZ}5y?y9=zaL8U;d%7#Av@d~*AcwFm5R}UQ5UO;Zj z6egEcU`Ow>tE^LEXtY3=Z}#zQ)(Pu|L!z6NI3C2)6jZfH7T3bg9lV(7uecsBIXy4} zSAXwWjlt|FZZGj2UTrPX^#{}-H&Bi^6_++1y4Fe_@wT&9On+gO1`b%oNTbiV0~YHv z5?iWXhh`S&^8B6kdm^$}YZTX|!hxvMB?}AFs3W25?}aP*k3Fq%qhmSUfMns&`czs8GrTuQXa1Cw?xm#{ugTdi$d1Q^+gezHVB@DkC-03ak&c+#N zb~b66z^yHsECXNwvH)yO%KPN@wN{c>^+-UqN&-H#G>f4!RD@QhA`d%?JmToheHPNN zH36k&Jrs?_x8LnTo?Ds|cNP4Qu7V>4!2EoMDKLLJaLmuK z%gs+ZzP}Ae|5h`(g|G{DGm(i~Ps{Kcx7)0oK{3D)9}ghY|Hh8d|7=H>wQFPAaf5YH z>=jUsUPyg8;ILSvop`%7qQw;=w;I_M;!ckeE1_{I-rVu{?beAg&jRPxkK1u2;|2gv zlB~|hoeU2=6dLwlcvS5jR_Y-7gKGx*1M7gMVfFId?18q6B?ITmh=t=FR@&+GI365A zb|7D%#r#v7PAw@5J&dC0B*Pf z;bZ`dDgzK7XnFPl*rK}AO7J}ANa~R*@8rj8?zF;UIcTtxqaUGkl^vDTkS^0US^ZPK z!^{LZ{1cgXg5ta7l1)}Z)T2Q+Kx~j3H(B|yFCiBPTs;$Pz; z|9wdR#^L#G08h4pK>ZIpG)Dqx*rx>2eCP1}-XmWo-yfX#kDj&nBl?rW;@<%**l+_` z{Or*D5ZGf_#YUv8UNGa@mBy3wza@=j@mSd^lsPv*q#GvG+B5z zt|(x}^8l7rx*ap*dd5OjEHM;K&&|#;Ffe-?o22bOkc8PhJ+fdkc;d4!EYGw{z`b*b zB}N2f=cvjO-1dQOMUu4t2a-seXOuLzpo9)~4DUT>EZWW<6Of(VSYQdUHc4Cn34$%u zjJJ7qk{^&~XFG-qdJiJj#m=4>kex$uUy+VS9}$$bo1L8LBo7Zt&a#uUo#bIoGES;3;=uvfH#^r!W?xOYc(6<84*U=mbNYCh zmyORk9eT)05AT6Ac71rYaOA^Q*Qoa#x-^_s|1S$4M#sq>lC{YeY@_D^jn4YsN30|@ z2WLKx(`0rEz^2-M{LGxJ^Kdh>({oCGL=`dZ5nMMqR)E!ZDg~IrH3ARva7PDrYMfJ3 zWVO?Svj9M0HF|J{aDo%&w44X?mjgJusQfZ*D;8+uWbsyP9Q2gltmVU)P=o0Te09KCQ2RzCXqqTmPP?)2V`J_93>04dg44T4}1d%IkK5Ur3U42cgXx) z|`{ncOC>uPaHiL)n5KI8bXk z7+WA|IevGNh4124E|pcT_gQi3LL_?um$C?99xivL9V0C`;oqO9RqjcTI+}1iA_pFJ z!Nrf_QGs!C6noPC!QVonV0}Oc)?o7@+(sb1Kv4ZiS^r#_6p2Oo%;o<6Cf0Ab}E3y(Vnb4=1&1oP`a4`V8!(Z4=ND2ftW-*00!x& zn6Prlh%J^(nDInp4O+$q4%pF9VEXFE-Pw>!ME zhw*`o%bLfnq^_;8AWM=JgsU5xLOBW;vM@6|P4x%I^VyTYJ-}xJUDn^TY0~>Sc1YTV zd#niZQlp$##|LNk6(m11s#MEX%Dv(ch^{fI5q~?j*3ox zy&VmDS`bU_dAp{i>FGXhHrk3NrgFql?py#5_hoBtJTZu`6~LD~9dYEpV#6Z5-vup1 z-bdUOf~#Z#RBRy#3n!jV7A(xuLHzCyif;(u4_kTtOYuNW$(RLjofTZbg#ip=96Hhl z=4T}k$N6a>o~?j*&TVacf$hnhKrw*~gA1GKPCP2Y>vx05AUQ)3p9><^CN~&(FjFNU80Xe_ zEYes&8X&M>Rs`|v)dKOU?BtoiX-HrK84%Bg6^JJT;<;G#<9)e1t>r@Wkei>g;yRQD zUBWs2PkHr1tFyfECc}z)2KU)hDcAKh+4PJkQLkR%NX~;sWq1H!Ff3MvGxcN9#Q+vN z5Ww_8q_4ucw5qD6tYr3r`STZR3u$Q&=Z#C)6xxs9n%d za&BqWf^yA`v}dfOp{At1p{}xe4kUZQit|>~)Xgt-wNW~i)Ks`6mDLT5*{b>zfz_(Z z=eQP_Rquvo&vruf3uZZ?`3tI?(Co@{olyCrS|?Od<*liyb0hO>-24@F%`{cB1Hv_K zsZ}*|PUz)iL_Sx>`g7`BU21CV>z>aZz(z*=8zr7qo#(c8`gr*D=AO{O{GZw@vg((Kk@M*~!Z zBDQ9Z7%f^=zdo*(2sv6JRKK8HsfnPYCPI#y#Mx>hE7aj0SFw(a6m)7`iz^V^^1E zI|>F`yqU(X2FJJJ_h3%ZoaPw48Q~bd83790+RZ4xuQj7=KCpT-%I4Gp0eTs9Fb$O$^HgSqvV+bD207{+gk=wKbS{XS z_&NqMo5)VDFE5{00z}K0UxZrp{QguY;!m{uwC1wxxLp#oRM7ywmDP5{tIEVUhgu?p#0JKv-|q{R0LTQ7%m!0=2X?pa{5=T zuAGBGJO_s|8WfWPHSMu!G`Zys+`#k78!!>aiORAPm8>}t47KHMxUO9F)itxuE~%_9 znT5I2JdKft(mCqPs&m85sk0Z<+EjH5s>?7R(W*+%TTBM^T;!P>ab{L+Pxla?Oh_ zjFY_*jN*`UaeYboqDnhZQ(IoGFsfat5ZJ&zi_qliRlKfze$Bb4DrBoGuP&W$2g~Np zuB=l?n4xUpY&Te5eXbiUDXp8MBHj{YZYZD6UUxn_H}YzzbU4)k!x6l^+|LAr)fJU< z6df!-8$(eY>V`34Vf zVEs|DHcZRbd~fWv28o_o-tVyDz>(GD1{{pY@*ctN1CA`U^d*h2_&sZxXxlBnXRrRb zy?tN2Z`J8yvYfWx>MQTsZ@pyPUNqEKdjKzOGd-Ef$vx(lSJfsb%cl-ni5*Ur$(7aly|?7jzghJ? z=i{qcyXD}It%ozp=9HBs_o%3@=`p*!qP(t0ZB1=*kICp6@C)RE>IL=Xvt{Q`tc)o= zDr!(KJt{CIEe9RiSa}_?jvF;JM=_aP)xF2?lX_Imhw-XrgF#i<0`xfb2-G&rr8j%V z+JvpKPiu{RI_b0hEak1ASTWw*yan}jc^J_0s^|CehtX@&N7H)L&gniBgX0MU1`If} zSFis5$f#bu2KXbzy?XWaM~3w3)z2T9(yP~r{>aq8JY#yD&Vt zW~B?N8nWT^3owFIRrqQ@weARSlQD+Im(kx@>DeE48v(l~r)H%VBy;RZ?op7;u?~}c zEF6;4lN)N1lhf1E(tQ2Dv!X@247J)w$xg{4$l@QYn6R|+>e*@Ns^xj#TO)kCzqc+I zqDoHs5w8{)EWiEHit9L1h*N|ZCB&&hoF>E=A&O<(Pgb{#vxJx-M2QeHg(wwbmJnq^ zlnYTI#2g{!3Q;M<*|Pj6D?4_O5F>=ZOYg=CFo zah+Hb5O>Kx6Q2XS)}L~%cvgjX;r9zamis=<#}mN6fj8iNDT?g-Fuw8=a=YVeC+5-C zi?oygz@z}yYpEhpNRcEyRw-S)hqcv;+tcdz zbCv5ogdY(Pi-*Kk@qpMO?i6>4jbf9yTWnTT4~lzm-Y)J}F_i^Bdl35?=dWCZb}H%< zd%=L=ijqHx>MDbuL_YP6m2Z5f{U}d3YW45>zV@z4YV;Fub#*E3oU-2Lo=LMU17C1La3NoC>-;z=PN{Ko3mN&0E+z^~fR+7Ube z{=K}n$?DW&x8Qz%;4xTxTf8aW5buE9TOtBm@$Qz^KKXqUx{%8Q%5gKU68x5+eO&5< zD*PBXr4pEAKem%U)Y%{Ej!>>YhN~e6hX~K6)OOR>MYazVr-(7x=?iO+4| zeU|%eO0Sc_e!aDEAWWwna; z6g|X7ZG(2BcD;57UVyACY$tWM7r$+ER2$I2$>_s*n-eCZ;(%}w5zaBzIlm%vjfe#7 zJWq2|a6TKbNYo22GS`Xas!ltn?N_W0s^9VGma*Te!uG2`nf(lTuMv@$J%wR)oqIOU zrP@qJwR6SA=*Xvv8f3aqWjulXS&Vp9HW?9d-ZRyeEmF?mk8{k&gH6kX&y8vm#1L^6 zVg=$fd_82PcBwz*GK9{;w(u;RYXG%?Du8_{Kn2v#5_KEkJO?qybx(MMwuskFM0BXu6K`5M85hd(a4*DA+zU8bI}P7CS&E0M?iBgjwc1os zs{N$b>OQTl=%ZC(jJr!rg=fw|_xmsXuy&e0Qol)@qQmeaM4aK(Kh;0byXfbLla0^x z1Nb`0=lV$F6k~-kO&m1dFzzrOF)EBwqpy~z|66}Z@2c<9JBb7OK%>Ao*Lcym)3^og zx}WyDSf&3VeiL{rkmwJYM~I=~MC^(W)Xvij@XExK@Uq=Yusc3pTmgsw2!q*KB1s=6 zyeqUEu~6$QGDNO;RC`Rz*SF~p>$8l<@ix~-^sV|XQD(fPCy1Z%F`7itRlFst^{M(a zeY!r*IHHd+-iC|9G;M!9Gb97o4KC=~1zxow=T*(Z)q-vMpGV*0l}&tBXrq9lhRjZl58o$KWi(SHsmz$A_OvA4Ghy>5z9lChj3`wkaI}u zoO@zUoY;_Kr;+j$z^j1%qEMVJ3eXkohahV(p1ULZ0pQ#tOTSBSC^(0{eu4NLNe9IG zgqY6j6Fw5Zh*jAI0#}5ycVranujohh=_1s?xCc>oC^20&tFk{4ZS)NyBcni1)LFn1 z{rRR<`fp8VgBFh;=!)gD2t zty3b^egx(wML*zvL+D$*4?;gH+yrr;X;tQb`d161ZOE~V_J(E5&#_Ii%A3i+>tOel z{+>QVEZ0{yU5(JMIy))%2(;yUFcI;^20OKPwCQ@Xv0VJ_EI*hMVN`aQs9h^gH)1-+ zbj~ndMZNMk6@sI_o6_(C->b!{%(D>p;&V&J8Ai0RDqBZ%RrWNaGtQljV*NEz`wzR& zzKR9zk-$01pyqb17HDbAI~46#9^AasM${!e`#taG(KA3C5grT5O(U)01)^L&#PGcZ(qR+4|1hEym8=hZM!mT+;El3)O5Z@Mq?uD$R>F zq5@@`YruhXw?>J6_iHr~X8jxS zqIlc*5SW)>(F;}nt8$-fS_E-kMl3OYEL7;1WjksGu$+x7^J^lzM+df#Yf%NOGS?Y5DWk8-G*E3b z#2{5@a}|;n`V$e;xyHB{p&rHt%mH|hH;<3wd5ILSk~HqpegJN`@g;trRjDuF_g^rv zrhSjP{88aZ%jRo@FvKd!g)Mp*e>kZx2ygtK#w*6})*Hrmz`bsu{A_V3E2i_$`dIy4 zpysRY$eyS*YMeF2bbdzb0EX;gvF3pe^aFa#J;nipDL#jN+Yq~jC_?|w&fHL?_s(3` z4>pJbeK*o~A)ogLV~;Uc+YcaP+c^^BDf>*lKzsw~X_XnM5OSO(p2kw`cPplIA!_qe zqf5wGJu!a2xI0VJUW5nb14bgnRU=DTf_DSNbY=xELxtQ9d+WwmMge*Q=-*DzwC#<9 zN{eV@prn*_v_8>@LHsoRGx4+d*7#UaoCH^Ldpo++&sq+CDe`%$AvY=eP*@)KAWwV< zhd!#DRsv&M9OK@8LRVQe11tMgd>DYy~S#_Fpwn^V!N=?9G; z3_2_ix8X7T39Q*3e>PWQzCpMEN?d?&d*k1T^?(dNu>#DRk6qcE`9+`9lzquDl=jU9 zq~-V8?4vs#W&8t_Gd$?&;%^UcZ@%Oqhxoza5Fz+D&uqptq03^~VQJtS(i^|c$GUX# zh}DNCDPG-5^yz7bI(=b&t&MS{o#YVrM|@P%d#Io=gS1`4f9zJIMvZnMibqyCI8#bZ zi&GM#E_^;68R6M$k z2UdBmlairZYT~t>zjeI8<~B(iVN8V76-KmfOW!$!67cA-?1Cj%krMM1-_E z-0`Z&-y$!FnTvas>e_+008r89k}!TD&OJVgS)reyQ_Z^*U0hM({uDRN^Y1A~Q>Z}l z;FiY1n>&(iIvS>}=qhHmaFA14#Cmilk9cvlJbY$E9G9zY`uViPki?LeY$nccNv9T3 zt&5nX4TM=s06eBNkx!TL?i$R-^4IIH4%;mf9hat&zeJzHqgQIM4#bX0)wIc}tgP;% zM!d(y{(<3@BQn#kPDA4)wUnC?~I^=ukoO!+J0uiu+44;cqF@6*pb`ms|7GZc9QurL1kTGO{p-sw%> zHFf&yVKMcukw-HEY*J?IGo~BmA@>?^5F9@?bU>xdFH6DaYqQB1ZjFIBnbjs z8+tL=_W-;ea=o$E`0(glWr16PDGog~Wo#dPge5vQLHn!B`3+9>g!*dq${Ix$Ww(I3P-E=hYBY1r@645O>o)z~ij zc#WO}8!0mMsm2MwjKJ4R&(iXN>8PD&)N4KU225_V z1^-SKU+E|7-eHh$p%|?XgcgIvtH#q1=0yD<2=a7GoTaB~i}lgsAuuY&Eql-D*NUg~ z6?!`X_7L+Nt)Kq5Zi+TW2e2*1-ExbKY(wgpL+E!I?M1Fug5MEZwEhdyPS@@=hUq7W zudw5J0%o6)qMcX#h|^EVI#=Z5m&N2`7yoO0moZc9Ha@{7;0#n$AMvd5xSlC8MIKBq z#p}jky&C&HZ|ScHORUkq(O2QT$@oqm4$(dlf1t3_wM+H)3>Mo?%+=4)p3u8tTd$jF zYituf?ALkp1-f^i(H*-pH;X&;KeW5_Mr_V^6Z^2VI*8T6n_@h)TB=9rp}3^*k}({0 z7m4}*9^*>mTalyF2Gg-^*G(K2j~Oo;M?@d-nm${+331O8ZM9Fu2Vx)gL{5Sbm0BfI zHo^x!gl&6^C_P(r)jsixe#RKlMqHxx7R!uEd<`ef*oT?&P-6mOCyT$tQIVuwXtdWq z1x*9)<17+o*fRPV8!exTaUw*&74-_{npdyG_Ub2MwyK6XdMNy=7&{sbpo}zL5tZ8K z*n+LoJ_5zr`env##t>1bd6{9q{w0Xo8GZH6sGocFKlQ<{rQizQO1%`sj7|twYx5 z#n<9K)a-X)c9GG~7%jfi2IvFz>mgjF{xv9m6(b?mCE5jgPva}SmvN82K#MmPK;Q-V zK294{z&_E%=q5gabrxV>c%N4!8{cY&#fKm|B1VCr9v|f?*2h7c%d~xBvVJSX+i0Al zRpJsu9{l%^Sg3ymAvR;fy%mOym0--|FAu!b~Mtl^Y+Rgec`g&c!cdo%=e0_|G;W&Ex( z2Ej@Xp#lzyC@~02bg$hc7T{}1-Na=mVhMJD*NYoOh>;2-F3|R9uVDfD4N`9t-y+L! z?70uZ^`!fZ!@`4w=@Bs;c8I{GnX%X&Z3}T1Xv0vz_gaimAkNXoYa2woh(#-lz!u&? z@L3{Oi@&h8dR_dW?e%I~fJznDVE>lA*FI5;iz{ykFE)v97t@TL;v(QWY7dH|TC8{u z7k47W613;`;(mM)szB@(EVe)lgYfsG^LiaNVT10je**7F)rJ`JjdS!#MzqM#&ew*a zHJl={ak*hF1Ug;&Sa=^2VIVw38-mw(#Nrx2cWgJsg54?D*~x_qF5nE=SR{HI7a(Pc zeh?pW&Ns%RkZg#W2H;;ZHviw%9~a^JEbVta9@tdz1oYk{mKcn|0#FHU0l1rtWoQ-r zTO<|`87p?{@yK+p_JZy+3PnCzbS--IPXq|Gw)zm`ElB$<_IzUWI(?+l;Zyj_#c;4# zU`~f$?-kb>FQP@}g1OL_B9ah92+}{S%~bf-|P*Y5G=Wt5Nt;);i;MeYtT+dkXvfwO(zT_O|i7 zaku^&Bzs=p4+h<}_l*zG5e?IyLM@Nd_G8av6uQli&;||}r^8=91bkwA3O#n|wW?pM z#qRwhc*NvOV=Ich8~x}M@tyG{-sMuO{b&r(iu7&T&&Dst8R8yX)M(HyL%w@(xzJl8 zelo`BGjXx_a^0)_3SDQ5-;J*z?KjxX_y!%y*Z4x%x1xtmN2}FV>W9&xEJ9~>1ZjI= z+;2r+(NE04RHCz9kJL}ZH%KiP-)be=OqlshMM5B+4tLswOw)ydP&Z&Q^%t}({h*$!->>!73-lB*2 z2!!}IM4it?-?|b-rik&NN)fMMbB8_39h#2x-}E!R`V@U8SXz3iK1-hsqIP<@UZHo; z=jl~CuWirQW0f#$QmLW_*&6h>wJY`2`X+IWew`j>)MDTC2Hi4l)YpO2UaX;NwcGR! zxR$U<_wiSB5%Kx}>@;=}amKUy4!G_s`m6dL{dL{@HWCi&dqL74ThSkhqo~19Bit~J zB)EAyIBuOCLIaw9sSMyP!QG5sPQ zxcCx63mgaF;yd+y`eana9)#ST_|JI1g@Qf$KIdbgyTsXD`@nIwv&ea`^JC|W`t{C7 zBzBSGMg3~$opO@;sAG)tdvFB&`sG0W1)@lGAMJkq3hgR=pne^~tJN_OupT&O0g{PD zS-&<=AK`ca{ro`PE3Zx-l}EZ@ zNRc0sp_HcGDUW`-m6w5deGWCOzWH&hPU~7El8$|F&w$Q0&4I*Ooq6866#`3OU@Ng8QN^jA8ooId#C2GlI=M4{3rJ9niZF4}%tg3U{* zD@ucEZDl7C^A3n@1&UTtcFjv`z(a-X=iiIVHQqO%N`Gu8zRq}-#qbm1ZF-xRLx(XK zDQuFz$aF_BOso_r+LPzmpuM=(;GOa+eWJ6UfL%#g48wn1gw0DSl~ZSu{-!jbqZFpa zaeN4qVz-$&rHJkGJK8&4b2}T>`)mh;>o^4)Ashm0!?aL>S0{qyZU`4DHsk{Ai zm$hx7A}$B9isD%_=$SjE9-eBS`quA*^_@t#;U77896 z3k74w1@-S72mQu)=zo7a&~qjL{n&&cdiX@3ubyc1jM%5`#Ew@xCK`{4#z~-kbrNXj zO*UQ;NmC3DO@+kfDaJ+-m;$6b7s%IgjVHn)w1c|1X{s^S@w6^ppK2tpG4#h}VIBty zU8&QVwh{m7xtK-Kcrc^SUbq+i^gStIM^2FF_hELo$%_xqFl%D=0{x>P+ z2{EF7fzcC>*dfn)<&n~%d4(scP)eJQQU@f@0p=B_7Z~H@T^0fmlFs{OTINW7ta!J; z=(~7=G--lP6im%z1YsDRZOj3UFcWaSctC!Gmyg8zl-wuiVosrvoWOEf7P(=9PI$Vr zMQPkpz<)C(Ck!D`(oaD0nFy6x;$WdMa&4rf;3Mv2BFCPL#Oey=?VS{Ij?a|0w@|J_ z7MQ5Xk^z3k5+9)m-jOpNGjw}nJnOP4DW&+y;gLGKozI-!FROx%YA31t{W44S#AK?m z5~L>@E5i?37APvby&g2P4^q^anV-%S-!`RGg9F94B?c$P@7Kh*nFe0un9+jdq(Xl*5$9O!XM5Nf5 zic*kxXtpso>GxIxVyR3+F1b%WlXC|iV?j<#p3}j9&%=Lr;(0VAlV z#tvJ=W|>x;UF(cwuu7^kl_LntQ1OebU(2xwY}L%1BgvU%6PBOpNBbr{N4o$&#&cET z^TZN|Zo+~qh{BT`H)xbll0ciRe_|$9Jgti}wOLAYnH3A4iIP-snF&VCrPw}cVX_y(Jhic%| zU_G2_*|ye#(Amba42BTj^<%g2SFTW;-);rH9Pf{8})F+KDXY9S(^ zL@Fu?Dq=zfS0*Use}~!NdrscqskF3K9rCEco0#tQ;KjDCH>L~ zM(XID)(Apji`1g<`~a)rBhiTFm}EM}#|uEck2S(#GJ5T+!YGHSe}By7h`xIV`J2=cEq!lM`g z67piKgrQ{-169UK9Jx{`Jz18;hA0}sF~@UwZf`Xnlu}aZOc;VFIRvw1JcoyeXn$Vv z&~f!rZHmkg10gyx5<5OE2a4x`qn+}rF_pB1J`og17^z$aub-07VYazn&OV6|7yVKM zL0R2YDUfSd)$t-p^E~(#;m3R`0tmVg_(eD_!fw}fXo|3Tql2uBqTWLZQ)gCb!xxEw z1Fv09!`p$xL`T|eO$tIR9jzXZFYnP#e6~Qzj>C8vlVdtzCgb@XyzUiZmXz-g0gdmF zX5z^@vCOn&=S!umI#d*)+1&9~9dk_+T+u1WWIb1>G}ZKEJn(~!vQq#g5Py)B(5#xV zgvph77N>*~J&Pi`Le5&pDR==9Z|UGE9hRZ!@O?t5N9O&=km@i;;yAW}41?F-(M`QmFXG zSo}mls_ErS7t#toP0#a7k~|q4B$7~La2$;^vGMzyv%p9(K-heoSv6w`PGdyA#X)?m zfG{($=Odpl`G|vYEKiR1`SO)fLa}N(&&H12A z$T2{S$}~2I;S38^Fd7`0_^DozaLhp(SY9?Kp&nS-{tyGSF@nXh0EQE0p`LBwSqNb= zI`BymmTJOM45*Ezv3whz4Sv=Sx@^Qi5&%g-Mx{IpIASHn1WO{RCJu@mIx?I&lmddM z0h5HE;!`+^4cZb&KM~T#s?(59lfgqUGKw}OfEXzTD9@^G9Kn^epaMym4teR4k0{6} zwe_I{GcpLO<&Z88)f(a6Pz+sRQ=X@bJCLTyC~vqM*I{F2bcIbHcQ&DFUCh347QHqhjL?Z&I)i72lG(6LZ`=*ZGS5a`8(w5 zqkwo+BqmeF+SG+Wigh7yqDv7b%@XG>HwN2RAF>(QB6%@}NF(suA$dIVm`XQpq zP*%uRK&GpWLxpp}P?6cb=;iv!R0WQe^w#D|YcXa%UNWF98;dbA5fbWZF-Db=FQzzr zYCx>Qhxn-ZEJOcPhp!!#;D+sBuaT-3i*qZC{s!UImMp5h#=wCc9mRbylVo*fm(CBe zTM0603(}W|G^t-8GuVldI8~wV;h|X;Z>N4lrbbk}GnWR4O4(;cp=c!y=~nVJ!R{5C-|F5hQxymz!SqP?t(OKnGaNMEW zotwfb{?NQ^Y$CkG=tVJ-?58JIxexPb@!Bv;MQ9&JAXP`9@otfJy8fqF;&}I>g#_c> zBIa<9kRPm}>7~bycrTR&TdS{E60Og`;5Lf9-9$<$-qlh=EmAyO$aqIC9}<*O^dW%A zMuszOp-L(5fzG8;GKTZ6N|*gir6lT?DgDSvJen4wQ?-PjTT){Gai!FOts^q|uVoTs ziVh)4gD{kzYxKw6`*T&E<)l9Ir&M;($mQ=^qd!;W&nsmIm9q3o;~0upbeeKw$5Qe{ zA;gZQ4|I9N*7e5FC0jt)RWh-6j80V+!kk<%VWr@-*`c*T;9n;0C@kavz~jf;)*Hi@ z@?*_EC6%a%mmXZ^hnFc$8^MoA809!cla3+&BO!3+WqLj;2vHFi^QtuGkKmbkhI9YL zbcEyWh)P&zcDNPqy+Fq7V`;j@EVk2IW=HQ=>Ng6u5YMB!RAYq$Bcj}cnO0w0Ha!HBp z#SZ1O&A}&Tf>MtE(+E}zw^^!H-s8YO&|5UTv zE`_+G9#<5$1L+^xgj!5OcT34EmY8{0>iGO>(9yePO4&%XPX$R;ilDYPcKd^lVRsPn zXH@);*1OWF98LMd3K%@Iqh$@gO5Y?~`2)RL^*daHnV8nZ;({t1)0CdtTe#g_qg{gA z{t?<`$X|i?#w);J=qvR8Xz6q*b{1}R8+hU2KJYxFr)bmB@uXt{6Ru}z8&L~)IW+w+ zei6DRd3^e4t-n6hISvtwH-P>M)NCw<%!SZoyvF|mR=Vo&(l%_xnv@GKC#O0!ylgod zPj^J&gKflv{}-rxk@D!px~@g(80P8DGw`W+U8zB<2e#EoQxYFu=Z(;Rqp#DQ_!LgA zUX6UMc9#>&llp^xtXH<+)m2SjigzW~BA22i>f!j3XR&@nD+XNC$$%w#Pi-U8xMKs% zc8yA&i&wCUA$F-_qjM?lwZ=P3^ci?{Zx%{^6JB)&Mo+>E+{CjKZ`EgjI}3%l9n!`D zIsrew0n~4tJwY-A@AN(m;hMe+rDe+x;#G*^%Z6K;1pX+YA$@JjD8X9UVf1~^d1+YudC;^o6$FlDwQ491tBR>Sq7 zdSAo?zPseO2~v7tkCXh#I40s1Px8Pkj&*twQn-r7BRtde`yDHE|5*JU$6`Ge**rZT zXYvQ5WAy@^mIP*Lv0zyup{w<5JPSr?LWZieV2#VnFc{c0b~{9 zmyJ)S#^SETD!lZT3O(B$8}LTmI^ERQ`|)z#MwEOxn3m$D#PO&@Qqc`BW)4OmrQ!Oy z81KyHB09F>I=lx$wHMwX%hT!WlS_g9P=C%5p&xSOIK22UAXgjl;Pre&QyPp7huhsy z76ED#@10V--46c8k@G)<*J~@Vwmlfx4>WpzZW_vS3?z>O_E#{S=PZNU56b5%;-FlE zYhS?XZx|d}415e=tC7zIp9$jZXH&%a4Hm8pqBb-j$e2)RzgEuC>ao}H?qd6r2w$3pHFj6Ci4-6#<)UVH!pZgEV(JK=2kbO%{p;uxb>;0qJEbwxoRT4kWUsZhCnxdkE4dZgvfFFsd#&I3Ye&tsNTCdz3B5fw)>$>vp_?}pv5D$DHW!F zh;syDI|}q?;X}_9j8pJtF}oegP;K<+kP}*ZYG_T)7~uW+&h22NzFSA=hDBhJ_G5^5}Bn_5X4 zgyo_nZ#(lbsx8CYAC6MO&-G+~OATu7qPq7Mp4RLgLT zfb1ywV1`p#GgePVZ<6XzFM>}2^c`m$3P?>N4iQYX*#m7Y3=ZlA{*jI-z)SofpyGG{ z>IKq#=WL7?h49=ArvU;daOmtD9`v|z=*9{F`2bye76vR&r#_R0b&4laS%Qx%XULAD zSjPw59X`h@=qUpKd{9InT?N_%-CqLY0%Y@H>o|xc0Rzx)mY`VNmi6P;vthO2wh?ao{;-@Izw(l%r^V zs3(!J_)!ck!;n?t=#7#-=P)pM8K{Iw2>VHxrcuca>=b3(c&Et5`wEOJz~>?8rf)dh z-UrHxF?ugR*z3SemxZFRFOfxc=$|?IA{B?-UjVR)np^>*5|q3Oc>^UUk#3YrLktz8 z1W6c{X*gek<1LO#l!f|Cb}`K{4b(5bb&7#J7H_XpQD|I=(-WN|(5k3P$iopR%3}Q~ zM}jQuNas{PrY!T|ieivVa8jSS1SDtUzS?Abog)`6{shyTYZ1bQ5dT-aQ=j4}LUXv* z=|pK4qbDhG$w8_{tPMXLT8 zx|TO-nmfR8o^y~R3?%blUlsbv1CB?X0}y_V`gTl4d+EdRiu{Fm5B~?pTCGqI1mds+ zP~iv!W@8}FbOr)9;wSJ61g?=sN-fu0gXvtE%E!@-(7wYt!+Dp5d&KX&5`qGO0*DO+ zu6A4_a|eOeG=c;IZv&#q8g#--C7_GIFG|u!!|maC-j$wp?TrT77tkubKR%`rixibU z5I766&cW|}lsr*#rJ(dI8)iRpo6+6B)iOsx={#A|jMMYvNLPSZqOO1`X5)N&kmqis zsM!PpWFL8Vu|-GY#9HJFoo=*eEcjUPbvV;VXXz6yw-|lIzGKndBa@uT&J@(8aGh^7 zl}$w4bJrdS6RNH*S#zG0{Xh$Hh3e7kWSR=dtGNh=#4FrOA zh_Wq4|7cA|J3)+xq49|4Hyc$@Ob*}z+lq0Qxr^dJ;NMf6bH34B^?zLrib0$7rssd5 zP1W1~!hIG0ivq!UXKgYH#akB|Bmcv&pqlupcsz5HG5vp~>#@y7^MB~WpHUwK2kRarX6J3Ec6|Gm~>*BXO& z3S+Wp`?WF1@-JC;vQh>D)P*qx9lLg61YHA)wUVk+DJ2a4-S9IU`eUj{$to%Aq^iX3 zOO1{Hp_&y?@l$I4n;!fb#rj`*5Fxor2F8Er#-C9v(ZP*=?ktJ#-w8zG`iW|jZlt*i z52oXgr)%U$Tqs~575Zk3@mnu9`u0?_g9Kdp1p+JZALzFjef=Tx0aAwTKePB}1RAs} zYXjogPGf=iVY@NtKdhObq1Ub%()YjXB3AFb(un&X6fbAT|D>BZzBM?0alnMm)EGje z$d7e;Kclk19|#2dS0y%&Vn^fIsDk~+sswt6|3?4H2A#Ycw>pO9|AkQaxvH$GE|dRz z_4E^}WIf56S}8ug>c7&Ae?lWQ<7HykHAZ|VM-m@}M(A9IqLAhBvGXX;&>yWcw?7;g zsG&kS_mPAIcf zdDj`PPQD-?oT!;7v2^}%le*69;P+;zp(o&347JApD{8WEk4!AQ)|iOr1y~gwI}S_) z`M*%Y5>oBD)fi-5w~-nex#{@dP)7?pfq)Y~s$;SC27J_HZL491QO710-fRr7IFWlb zX@C<8EFB{{S}sx8O8{ghZELU;u~x43;5|t2RNy+B;Oh{|G&M-o#oB9(A!1>x5jj{X zBm$Zn6k?f;)+)&PvqfOLF|dr57ZjQ840}%8*{+|8E)4-sZs4m1+))#cUXL$;!JHws zC(65OBolcfjqDW#`RRD>>sl$gYmJ52X}PDN)fm2x^!CEft`M>?P6{FSblgs&7j&eyONAgv zh@aNF3UuMR1&h|U1dfwH;AB3k>Z0BD5lQXpBdQvEvo%rRS@5A9uEvNVG^*jFwp)$N z|Cd)IOq@nN%>VD|&#pU4b*w*=Yw%?CHyFbm4Y2=S{Vl+I6M?{wH^Va7Z~ix$;m-`Q zS+d0ceow(Oj*ebb9$qsP!cX306Lj(UEqJK*#N8PSp=Z7S-R=xe2--`?U8*{0G zKjKFvLYauyf}}SI9$MAKfab~Gp=)n)ViW21K(IFntodmZhlrK88$GGLzJ06FPdt2^ z5r67Wb!5tXKA)rtts3Mx7EK9w9ekb8e{YNsj(d!L;hIKWFHJ@I`C~!Pw-so0oFwPT zBNg1ft?*M_{$$+N$(4LOt1848td`|xW0tVavV!ER32!m(CoQKZ4*~(c+d)X)+`+qN zlvm-F07_oK7oWoPx)ar%DgsIU@w($XFrm{MUJZ$s#UQ;@gir_Gc!z;+FKc85Z>hm~ ziyFiWfm7y^&)D3q^-96Q<`b0)J)ZMWy{?cqhB%~XG~zl$==DZ-#$*+6ADOXE)ZA&% ze?bvF?=a%TU3VJM;$a;8ldVe&s?TT)v}Budv|XR-Hf3luQ3=@@_H8A%e4-?{5(^63 zE}Eurt%m6GTgvc~B8YiAv9fUp9=bvyW$du7%7|ap_hhSECS|IYSI9LgUK}83q+UcP zYOGYUQ%>kln$C1|X96OXeT2ti)eUEH+7(9sK75f72q>4}=BIemj>9czLDJ8QR5AlfLP zEoDTeI;fwc3~#Vm_b=^Iv5c)9%+;XO3s6r7l6^hSP3gtWnA-fdyYvXaDJ|mGjyM6Z>sY!f8cPcpOQ3Q?%`-U#_%qJCnGL<)1TjB!& z`VbC}QmoVm3@a5|@5PY3>vsIl@T&Xpb&bdGHIkEmmM)!G`=(NJ4g|WYQl<0ZbvP=W z*m^s@rt{emD5|*67}A|BMy#SUf6N&4^UD`A>|`oA@B;y#h`8TK2&3jIvhO$2F$o}T zJNFxLXvN&^k{eZrI>Yi4-H<0jikOA+j(W!~gJu$3&{90Gpl-<1H=<(kJPl?RvWCUN z`_YPXsgqiJv(bB{iitc(CCPE#xb8LvRH{~? z;+$HC-BVGVQxvLAHDRJqoP?uCSXA7wUsQW?%cff)L(8oUn}TsniR9r{O@gQe5ym!$ za`eb1H}mKaPAaNB_lSjK$cdP|#q^~1OdmQU0@_6U0|*~1@r3!+;G+yYdGE;G?qtZ7 zGOTWf+@U&|uFctYitP^Oremt^_Jdsw6AFO`3t_2JLr|`DrG`x8!V->@s@{oY5sc2t zMRs4t7`qQ4r}{$`so+wIuxu+8kttl&N)c1Avfja}CLbyaTa8jnXZErRDFFNgMR~{; zO|unsHHBiCoT#QnCsw4~tg4eM%`GcU&B3HftI{U1BHNu*pGvd}Z)Tt)nVBkuL6JEA z0A?|6fO=bNW-Lsx%W?%{P6-QI20pd1)m-n&`ICcPI713CV(}G+@_;ndFE2vaF1Am( zfGj0es-@8JpretoXwZBaL&mU?_7IgSn=6~Cz9d<6riVR(Gy<5$joSJK(r}k9AjjoB4az5O8J9Wl``f$ zksp|o{HH373b?!jr=JDewsT%7C4Z1H)XYecQp%NL_tVNBOsz~;)WpwG5M17~WXcAl z$XO^6^F}potp*}>q7o{hR6>pm)opa8W@DI&{K3WYlS5WWYg8q$&`@$Rhp0{_l+Cq; zGBrb4O;?$g>HZUxOZkHY*fpnwhN>ZoP(y8h6oyQ{=t8`!>BJkY`?>U?LJ2|_;%a@M ztL-XCPbQQ^GYz|2nckTmrq_Z{5h)`m=v1Ysc5xyjnC1jRrFuSe@}C^Ii$h(;Wb~i| zspW}UBx0Q=YK%L@IxDHHmY2i_<5Bmac-VayJSOV*8rh|MM~UWD_VkoE)%29o_LU>$ zc%#7OjUO!I0HwKV7?vY=@h(dDiNIdt)JjF#ar#D3p1x7g(ey1$3hn&J6+Njzo&IVZ zWAHpBO^IowS1Vjqk}D8MAaBKp+wa83FK{8&dw!lo6v(5R(yF<$GHEfcyE$EgGbvgn zJ80WebahU>qWMZ?g2_>RPC zEF7FjXdEhF**;@R3DvS%v``lz1W~hRN^>oD^b^-IdnMFz>fYdf@$o(*zsu~O1N=i7oU2gk5V6%XoH%}k5gWmeXIF{96UN|i+-I;P;;|*!D{Uu}gb1zM zZzTLTWQ->}!ch_`5m^!1c=*zj;HpHFrY-~*KY5oM1H!pTxQZRrK~RD0we42;Zwvax z7Qr<)9x!6X)_q1;f3nstAKmqohh9foP*y3zv#gk>If=k--$%5z5lLbhKCCPATsSse?aLer+ED463|_KWAAG2&f}wf#Y+gc?S8 z=3seZ?lZ=K`6!{~rHL}t(Gr$P{^C?;OO#DPOLCtvl9$*vP|CK!PT9^OxuK7pv!2j8 z!M6t-=e5^8Z>-nbKRRSwrHj@VjX612E^Hf7U)Ip*tF6qb_MYx-$gZib*7aSBPYAxR zJ?a+B&?h;;h!z#JYNK?b(!TI0y9g4ZaO!O@WPUTrynd`(r_3Nh-iv3Oc?K}+REUv1L7GWUWdiOXtzrze&8 zYDbNnIG4OLF}}HWeQn*w+W5wn#wKq~JgJJLFYUm;_{N>~K%iax`mmAG?YY1_ZNJ!u z)IF)GEGM~v?H;x)n4#%YTc@Dh#o6_RGPXggvIHR&ru zitKbv3_F7VrL*ha;K!Ez+ONcEyNy2Gwrbn8?PAbtMrs0mK>1W{6@F{*|CTqQh#j|W z+Lfa6HKPSL*WP)}m^p8mmJcW7qTq!nY@Rk6beD}rP2ZH=w?e&S^7V|c5@4SzPq=`+Qve>Rrs7m2Lb zjf`#^@c)rDvF#0GOb>hrLvGrtzLr7XYO2@DaI7EzHVj4j-;Hc>$s5K83+Cd( z9i8`0Aknl7VeCb4Kq$5fpX3PLSs=R{Mbnn?mnElsWyIqPJ%Iooi4)tYM6=(j#=xZ{kI*RN6VZ;wTSL?bf3Vfqhyzvj*mu&qr9zuNjFUDfqVwOf0pC-+p48 z(r1E&pi0xUQK+;^as4|+Y#-bITtk}HB6_`p3&_Q$*|*PS_&7_aT`YLVsO-c4p}oUV z9DK(}>eIRAkr(<=V~)PQecn-{EPPBU{_l6^-G|Sqbly9-OdS6R6V2?8qkHP5LjMrv zeesdew|)GF#vZ*WwB9Klx}A-WnRMP2o+}{)OED6oSJ5f97ds{tTlS8TBQ8CPrGb4P zxAYKZzb8x_@l+ zouD|0`V8%ykewjZ6m98eph*(_#rT~i9Z52xyI7{T6hYUH4G=S_eE>+XsGTY}XS?&{9@oFj#|Q6MCKkDI`2`eOaBPxMA(UC?tx)QcD93v9-^$5}rU-B;J0sIV#}DVe`oritH{xB}yJ$S&$$M_>8n zm&OOe@sH@flPQyC`orMpPSv#qT5h>po zrZ{J}(H##;5lNLo(^<$-;uNQOP0mcEi?xus zk%g4dG?7e@Izl^ql_spcDJY%A?;U0$IV)Nma+u+hY+NAFA}z%;6!hg8E3Kro0M=<| zzkhx#I!-h?%)S#8JF(Dr#O$3QY`mgr(KbU|Ag~#~7WV88huJfS^1Rt88?qT(9d_FU z{}z17xbq$=V{-?rlF1fOj%XGA<_^P)8Y)7i2LcL8XRwQATmc9;V@Qt>OwhhdFxRA( zLKJ6plh;q8th;%;_+6yA8COG#qRlAcmEk~ct=onX^$hfm$IYxGT z{pa9b763eJv&*u~A|goFAtm|*9po~tnC+saHGFBBdIQmb=j+w6aDOrvYa?D8`A`lbdP+QK5WjqOQ;%(ETiCgrV~JTli^UDnu`)R-5aR7S^% zl*l_ZHQu_ajgN}A$>as8cyEYV(toUk^5uAZQlsJ%bwkbJeG!*iJn~|OFX|AbhiRZP3bn$w! zIWQwu*CRoP@8Es6rY&rsuKfT52kF`;$PL!D&sVgC4bioBIDM!XmSXzE)hXtBac#PJ zo*12Brt}*L@6+N379VPxkjDB4zH%tmW|*F+Zn|^f(x^#!nc}mFWerLA1!x?!yJmS#xi1yhd&2JnLZpvy^?L}kE`Ff-W4ocC(4vQPcnzO`*W6iB8 zqxG=1S#4qX+T8{7+rq}`VNJ-5)5Gd<8n1`>=C*}R(8Ep@t>er*+%9*fFK7#!t~;JD zaV;!skZVBMmENY(rn1Vmu$j6u=IpkxS-P`lOIuix?(BinY~49*Su{;UHSP1MZDDhD z=fGucVe@pyF^HP4JHt1&uGP+It#4_?RsYIXnw(qY_*a;vG>NA(T~LeC@n&t0Rl4IW zn7Ueb%o9h(n`vRCx_)naw+ZI+VL9i{lg;i|D7919due$Y6+UmZCmyRo&EBL&Z*@f$ zA1PLyZNiaj4%aUcNx9}k{kLLmt~n$s>}$kpKfPO;xG>k8sUK`Vlxt?_`me-4r<&vR zyV^(PnV(0-U%O;$UR&7ty4G6N7IuNwRJ1j5NnMS1YvTO6T5ns}CGAB;W@K3E9ccf9 zb$v>O48@OY5sJF@8G!NV4QkrLhUwbTbK1g&i-vjTxZW==l6Ci|dE2Nlb<-U$3CDc1 zK^$9P4r@O$-(2qOmn2(xeAKCVtCm*z8slXL5#K(2u{p>&W2PRqV?kSfe!lu~S+^$3 zf~P|!zNYrZ+?=K8btGf<^oEAIhECzve$_Jb6Q_t@X^w24x6@iMuC#j9zT2Fh+ zspdIhy@T}`Oo*s*b9GeoBR7v&Idj?JsqMAp=3sr%yECbMMhz^QFpriC(b}>rs>_<1 zytSqEWlg2kK62I|J?gG`yq@@*ygdAod!qh^$Q!0dQ3o?zkNTppEi6HgdPuzCHpfRU zK>eoaQ8UFLj~SQPyy(ijtH3luk66E?Eo`J7QL>R=hasU{kN2H3C9&>cucj%(0 z>fx`TbI#MlpGL6c>)|)!G)>&-F*75l>)qDC;u+$w$4t~`iSImSf<7DnG0q&O&lP!I z^K^ZYc+hJOj$ERLxk0&9yyb;GEA+65FlnV2Qh|nlQHA*_{@3kUmFAR~bS!_CTD?{< zDITvhQ^gOJ=CCmHjHo2>hbl9^o6qB|Z4!4>nPVa_4(JZgeDO||*;o9t%A6QBKzCM& z2|n`!eV9mDXAbR^HF?zFJ>XBDIGUu9edCMs#1C&MEVFB!RE2+INPxLDV#xgL-Pu%}&}#wUb<1hUT(S zEZ$&dPsor168b$XbN?nUKS{PHsyKbrv?K{lmmn!Gs2Ra6Uf5s`5XVn9CyFU8=16gN zi<#+!1aVu7`C8;na^B#$SX^?3IVbWtbS_c4en`A|hB;l&Y)?JY?5_Kt&@#%ZtLxmQ z(uBvCA(cIZkg}nK$d6@~=Gw-x3a=C_KHDGN zt+%T)e2nP%B$kZu^6@sapT8p-a_pK(mvtoBRnTxW2ZJ{lt9JB-25F`hure$&>zbSD zo102y4?k9APNDw3w5hI?BW$eb`BZej!I>3xG-PoRb2uRDDl8gt${I7ypH}OwR4yoQ zR4If7yQQ(Y+)C9nS6eBMZ-bTco?g$X3{clKa5}vL^DqT&ut};t!E{=6ou$;Df#e96 z#R&->8w~i6G~wks~<^Y;c6KK#&~- z!C!uBOhR0F$zhOTJB+on!$vW(+}G4d#!4G3m`uyI0c2KCIypBa2M34b5KA)W=g||6 z4ne}%AvriaBnPKw+A7eD>s?<8 zF)UBzU{j_<*JEq}mStNRAUV&yCX_d1yZz)>20%9(Dzhv{3ij19pOt|ewuj{UYO{k1 zF~}*Ou*60;Mzd;MJf!1sgHms8C6d`Ry|%Lj={24)R#%)#Nvfb6niy49*Ogmccy@!A z#v2-c-0(26Jh5VuaiZ;|=>Gn(zS<3Sm{rmejTa+%bFCaeGHGz~xl1KShLx#k@OrbX zbc2@$h)g-@Y%DFugl&BaWpJsSL1(I7q|+#EV?E9Fk_AsT)VeXR%kfv2ozYV2!;oIr zu(7PcGfL(w>M#S`s9>3>P6Qb{0`|fJ41#!oq80^3xjoh11{dmsV;)|rt!%2wa?5$Y z8m=rHJd|!FVIT_Wms4~(*UGUF>LR1l{9U2dm4+**&bovcsdU&E9HTmdq?(NKYG0FO zRz`*2M@5kr3YqYNT&$r;yJ(7{dEm3*_hj4B2$6ss<)}RJ|~!^ zl|g@V{fHm{6$`m&e?bVMthvTJy1`qCvSD6GW%2OLC1azvY<(%$a;i*2JSR|&ED50k zx$Ej%(wVl(>t3H-fj*}i9%7057*T(P8MDykX{kk%L+3!9Wwoz-gaU962gn!&!R&W^ zb3GhXQ(jjcgkrR!>Z|e5_1$=}?Q%1|f9RD={ta8V=0)Nk0uIg;FI|oc@Pp#(%gyxO zAr}n!v~J^=A;w>U^$3Hft@Z! z8JJckhHN(n=_5tnc5?tuYxr~)PC3@pOic*b)hC#ZF(O;MwB2;iv(`+c(}UNVY*+A# zle3{$n^r;Wbr7yJ(R!ts*C*YcQY6z5JF+yn-SKO)N^fu8VRmzfi-dVbI6qJ(99Nn7 zc(}LlD)SAIakZJzBe8Jq!lm(v1&a%oh~lfwb9&?kTSvTj_iED>nMh-4e0qHQ@N3M! z>cbOi8r+FBjT_u;qj|`xsn4MVHA`B&*54Ni*O{aIL>G1U@H26#(%|)=VK$UC_`Hp0 zV-2oquCIJ}{O~jD>)ked;lhG~#kj&k=apS|BJ9$-x@s^sGPbkWB~6}!P_cfcj}RT? zcIGUitGWsdtHhozZK_=#pXC{zefqHYge+hDC@gXZ|FY_k&OSZecW&$Koyy4k(V%FVel|SzVx#hLxCFD0$=Ih#PdHHR5N%^#nlfUi- zz?0-%qI}(XabEtkw!GwN%@q~i22gGXC-5oL5CWCn+I&6oZQ{+MJRC!nUIu8?@AANw z%Fx>N0Q^SsWfCN(9z#r7CCQ7ro46&k5#tiBksARVB~2)x3+H@YZxCzR%y|D&qD(0O z48tmjo+hH?0y(~cYN0eV4f#e4O6Ao6T_#l~70?Z@d_C+I5|CO5=QViip*yT5Z(0FF z6#6PLnxkxQaM=#lD0U?$iArfv}=CEbEy{tZwp z6*IL6(<^!+75=_N+_l@x81j@XZ{l1`)FAs97gatqny)*A_%!ncW-d(2^@ZX>B_ zbL%i=rS)DIcZVcToLA;UU3HfwO`{CWGfO9iO5sf?=7>6IG60|O>%8;Z^TF9(jQnb02QwOciDKA%5?YMPJffPKJi%6K(PmJPPctg8nO| z{v|CnaupX=u7s5c&a@>hC>ovwhUNObM3k_kr7>TdBa=&In5TlYaQX~H$x>@d2ij$1 zt+Y2|DdvTZ)jRJuBmL!MLplRE{E)ha9no~>48fvkO4-)+n5|LPfc_-@NV`LU)$s0eV6=lBaX0)rBWZLw$ zMOnTDxP->|T?6F}E&0?9=Cv($71d%P*XN<&$Fvp=qyR=PNtt1>Pa~?OY4htaf54ic zCw~Ue%TP0z{nM?i{Co=I;*9CF9yukX?n%_`G5gQRpAO39*-M(x-<4wO-+(FN#{5|% zZ$&oo%S$j!oqcurMIc?7osX*)T6DEk&j#fx@phs)(4RktN>Mmt=B)E~{O%D=>yDe0 z`lXuI?MqDyd%m^R?)hA4udE-x>5;n~Gj~oH_hiwdmjWr97}bHR=ifg4^x7LYOlTed z;i2kJp1uo@tqD?RM-FM|R zyNDh=vup98F~1sj;df)Ne7DDe>ppw%ViW+B@#9*J4^*GgXI54>7nd zSz#3HPkV2ue$%sG40&MCq1M)5B)KmC%|*`)cw#1IjlH$$ zc>2}nyfAgZjoR%nHNTOb5b!p-!ZUC1XPkH4isl2`3*OrDRzfp;hAzidJLKp$<4*Za zxOe=6%ckdk4%gd_&9x!p`wN$KD;R&xkvWTAxog8<2vlRAE9ta1=kEFH_J*%wza90a zcV;w|-P^DMOY<9`&hgTpK6$z74|9gE>$dIaXBl^(<_i3n*14h{-1OVOFTL^UdvA2k z7?s|93q-0e%jG_^uf8WO=W%oU_tO@C{;y}q#Fj?ahFx1P`0^`l^TvKFE?e=?SbDdD zJ3ZF}Pd&U{>w86W!XI8QJX&5g8eUpZPeW~^>(Tl9c0K#Zyr)OG7rpf7`%;GE?Fqje z#a&`;uPZ;k=FMX>o}L-!?DN&%V7NV6y2hTp0ijbt8+T<;xC z8~9IO&%>8|``y3Rhu0&zQs>rTsRI)Z*N*R|J>mQCg-56CiJN};x9{Cd%|#6|t~2j^ ztbbyfDvTKxXI z$Ig$43AFcoz_khPz_h}Z)2ILLgg#4$q-e!Gqn!&2pexwJyRLmI?v|)AG0CfLa7;M% zNP-8*;GpbxiG)psM{nEs#@}zQc>cZeE!Ut3>i)KC#tYvUg@2fS>aX6os64{+PAYs! z!HNl*>u5vfZwsorl>}a?+;M;GN2^eoB-9miww^QVZ*L{lyxCSh-}!wm#Hl{j^=;2- zSGi07`tGsx=m$$GZ}yS@<>b(H+5PAEH!azFVCT;MtN$3;vKb!6oC6)P%XIgfG;hV= z{$CZnx$o=nqJuEO8VOxrE~y>%(UOH<-@4$|hbpdIe>qgC`HXA+ha<-4OlqI^{jjXP zdCAY70)afIaxFbJ@}lG4XH7bMNnO^{SNku7uYx1J>x%ske|^;-x|Pg+DAC;caB~AJ z#Jqm&XjjbkcYB?&bJzK)nI9cLZ(P?FrM=Jl;Qv21RgU5_3S=^|Rc%`f?>%I5-rLFLn)+~4;`u!qcWMAr9T|Dp1 z;|bed-Vj^Yzow;ZBoJ~o%s8{a<;!T;Gf3t z+n)LTmft?r+8R3fbG>(Q!Kw$6!|%^N?T1CPBX5R%a^mHxoEz`DwzR~5bj_TSAMShk z*?+AP9`KVExh`~Ih*F8YpM zKazuxtMH)%TTUy?xixi6%J6I6dnJ;zU_$3QGU3=iCN`!GZTj6so8}jNNUu}Pt4HK`v9N+Soot))a9S=x#{mz=W^cUy5*@J=e$}G@7{cH=&R}4&O%Z{^BY&`U9HEf zXRkaz@lQ9N{nBkk@1yF})Yuice%{R$*PnLJAaQry(J*5#{17r1bG^O(pWk0~>4WRt zS3G!S?w&ZfNnS3Y-EJnx@7qaq_(YaZ*juj!sA&xe`T1%d0`=MG&KRr=Z$3l5o& zUHJHZsI+IiuB?=yqetEU=<)k|th(;lStHSQQm7UwZjFTTO|N`@bbr6scii%?Co&GB zbW6C`t-SGvdmdWE`2C9y&waIT@vhAW?zwb!-7+w$iyGJR(^3lR_dGlH%0K+7 z{loV!(ouo(!p{{o@}sMIHka0j-4E`b^702&t$wJpW|ywWo8Efusx`;Df12pN{L346 z4WnA9#v?YBjjnN9&OCb7!7;ymbnVnP9^UY6nPnx-HC?ZMf6cPJeRgM^67|Ni1<^(2 zh*eBrT{pbdy6s5hZLuwBY2xu6C3suUn)17DpMJrniWRwjU+?pq{38NigCj{^;kaHH zKYjZ4KRk57196czWk3DIR>Y7ssg=Y2#QO^hpX~YVt-XGjm$pCQ>Z9P37n82QBc}}h z^1CfXALTe+z2J&h&wzPYFOZA4uC;&v?B$9j54A2Eley&FFJ8oa#h&oG9`1 z>|>1&fBpFF3EP3SF6>;#FZ=7ZPnTY)J^R!%6W+Qn5pM{p>8V{<`sZy?VYqVRiSTuextb#PlHpQ(9and*$5jgE5yr?Rj_9*RS4wZt?l0 zFJ1+SeEH&f;Cwj#S#9T8$4hp65wYca_#W4>u8ZEd^t!Bu1K(CJJb3WK7B57?&!&W$V?h-mLTwF8{|9O3FVgAy5O@HdiB`fAl!@qW2PODFt!Q%fMYY_!l PN*OU>!i426*SP-!9gRH2 diff --git a/boot/ocamllex b/boot/ocamllex index 3164862a075e202aa598757ec9bef442c19ec011..874575575fb83300b0e43b91cc86f3a56cec206d 100755 GIT binary patch delta 31951 zcmb_l349bq)}QL!2_XrP3?YQc1tA2IkZ=e=k`V4gE(H-JhGY_AE=ZrJ)3yRum zsVJbhva7D(X5Cp&{MKDjaYbQQT`#=x#`^$uzW=|wYo@2ky8HcpUyrY=-m6!yUcGwt zs=B&^F9l+E?vA@=kT`O!M~dHG>#q^F=?6uw*sj+E?>m@}yTj#j4Fza=lI9UNlk3!N ziiVWe*?_wMFV@Bu{0~3CETnBw6S6vH7VHDL!ICBQ0Erv zSa5d_-1qj#T@&FEFY3OC#&IZi#RI7Oep~)2To@P{fhuN^}9{q7gs2#WiBih z6OpU;9u}*QkDqPHydyqO+^$y)$w*g2K@AcuI0xzN`ib~*)ZK@EE=U+9Zqzp=G{>p7 zZ_rO9)QP9{nqKXYc(B(}@vL5$n1TDWM1MAimcyuI)AGdIEZS4Lr*{TyR^Hnq4s|c> z{jivS5sJnD23af$_c-t@2cGS~a}=&OChLPAIuQua{K{NSR{jR0=c>H!N%>f8=}zeL zu}F;ru@J!P161yV)T6hLcKiMbj4sMjPN2U5XTKEwpjFOJcEFO zaE}8|1CDlmt^%vS!>x3fLy;Jh(N$`dkF?S<2j4fx&5n$<${Aa1_HrFXxgCGQz#R*;c(-Oc_7s=w+wC?lAjEdDSs_d7-Nk^xp zGt%i+>ctha^yNeP>BB1K>8E{LB9e5^a<~3i#pC+V75()aE0d#4zND&I`e&6bdhb8P z>X%n$#gTd$z}3B}>fvM&saG$k7E$`91s;*F?_QAWEBzr5U^#8hv8CVhssx>LgxB_f zIVSe<`6##JD;#*21HarR&l{5G3pRM4qr!_0Twq-64Hi4_$qsyp1OJr+zu&-@hI;(8 zgMprBZ}3M4-X9)sFXz;<<1@N*Pd^xu`VSaz5rE@a4`57tN{=}c3r_dgGmmJ9!|tWs zxF2hD>u)cej9mUQAMU%C)!-g;c7;{8{OqB~Z92OQ_lM7}!`-ud2k!fp=VN6$QJSk4 zjZD@D)T|);G|UoSxm`Ox?1 zm04%2##AGm3Ix>%vc@{hxy?%{#fZ*4>vPaleWt<9jojKxxb@{@V>1;i`=R>6KArH>%rB_@~u0PYBr$4u$S14ZS?(;Xmt`!$}^gmtHPk-|KPxL#^ z8|dIUvY|%20-g=}A3E|vYU^KijIv>qI_=oi7oMYk**Q@EtUWf-=qR)?B9xwSk=0`N zpDx;|#nJuP2hlzEl1;+5%?cVSD9s1Xq2iE`M#CQeIS^1d1KG>Koq_E>Ok)%ofmFgTDFlj7)lhoo|_qud(}y%Zo+kbq*GWFePe}o^(aI@aeOz$jH3J z!PjWxyI9|N#oE*>K;bT{#a41jchZ$R1U965emxfVqrWc4J?Yd8ed6XU1gx6P*l6m$ z&D?sM`FA##A@AOj4|>IxrHlw$4yHV1iKP=5^HJY$RXNK1SIxpb;_5=&i?3#oedp?S z#NCBk%Qdk_-+FDgxDR*P{mONZM2Nq2%NzF#@rYh?lUqF6z4oTYXzj~r{mt!ZJ~|qE zJq?fz;2dL~(~*;%`6vL#g83`}2bB3i06Hb}nE(bl<{3gc*s&JQ@gz2Fm~%D63DDWn`nDaH8C29#pV6O?jPjJQ&ebdzVPsgX4m3{Rtm6ifzs=2R=s zMp#BASVkp?Q%T}fk~lj-@9p1RvGbiceaPB8UAwrSzI<(#eB%$Im)>?)Y~nDK^I8PR z(~n)4p}+k|fBpTthmT`z+MX)XZaDyILr{1r@vEDcOOMjlF zMV!#{9vr4kKcUZiut?PDz6W!~Rr)U6KhyU=nCr_&Kv1sxIkwINJHq#6vr>z6fBd0{C5p4tzRrIxqcDHTFGdRFuA| zXnz6C8HJZPWHkdv71V)~QM-#RK^gjyhfa*4$VmWt307VP zh~q?{n!WTLW8B@3J#ue!BK?-l&o4~$_n%rUTmfmK;Mm(N#!C#Kdm}B zbreuu6jo&9EMfYZ+w+!C2rJTqxp2}*^y>8h)}WpYQ0z7X56ej>9s{6B)WlJW8MyAb zFIS(`-A|u*U;h~zxOlOIEh+Edg!m)OUx$>nl_Y9l$JrXY6|GlPdr~JL$BTN5F>-oCN0E{sCs_}jXYFXS(m)MF*#`mMdK7% z0vgB8MjPhxIcD|kJyi6A=8}87!kyS<1q;KF^56s5bv&z=Kjc|4&@n+P9k|zlbG||s zV?-!Sb#ek4NU-SKp(y%4e$rPh86bCc?6 zi3|0E&tluq9rJgc&oSGcs{wN2xv|(#beBC}tVQjIkVL&W)~#Q3XaaT?4&R^x{_+M-hwBH@~{p$i?b0uWggdQ$=jbOcZ1TxX{s*co=@m zlX4@v`&Ymrz!AWQ`m3+ii7k4?>uy6pl)m)!S(eayUROf%->9&}HwSZj-l#Ad8hlbi zR--YjGwp!g+queG@Uj`S74yWMl&dR4<_pzz&7 z{mFOx>F2&%BDU(=-YwLwami~Ii?r@H-c1(by6$7|Efr!z_pGB4nz*)m?uYHssq}R! z1vvpm%NoEl`r%{K(Ep6jtF2zweO_brb^qs$C@KB|yW;M5zG&uLnEO>D5dT+6MD~B3 zE3T96slqL%_Qm66pKrFze+io!`_`fjcmmo{eo_aVZ7cj#2md~t>Cm}V`F8!-Hx=-)Hqj(C2Sznw~TS`AYSqCGHu>ggxEU zwTA=9!QlEPOtu6mRc{1j0k|M?Y^MV_4|4!X^4N`{P(QvT*$}xDBwkb`8$ipf1aMhl zRk|~q;wFWiA#m*_uPTq%kKLaUWkeHM9xE!AOhO^`;F3B8K%uIE7UZ)46vVk>I6hM9 z+HQf;8K|K%d8t%y85kt z7R8F#(bYiNm{OK`rC=NKY>BPp0XUrIK49Oso3gLBO6Uh{pAC8~8o6idjo+1J-(XS5 zB>?2AvuGyQ!{6l>ka8~IJiu1K?*S(OGf+hW-UECF7^f$EpF3_4O1LZHs8E09HXD#< zRG$Rkw%K0BI+1$C_vK=!zTx|f(V4(`O$Lks+z4Rb>6*_1D2Ht@z@cHo)06dt6P`p` zsuI9!soW7IaNGSF#r1WUFpEUIwc^eEejq-UR;tY}N7~|GibGEdPH|(SPFKsd&qO zrDF3>zo26B|BH%8fBbhU-uhpuxb5d(Q1LGi!Rx(`P&C{KtU? z4>wyo01PX1XYQS<0JPx0n^>Ytj|r5I{-t?Uj_N(D+!@Fp@!!k~DwItr`V)cN!8?&- zRJh$r??B4+Aq&7L$g*8GB#3-pn9`s!UT_w3Wy}KbqR|<4Nn_Mr2Ix^+&`*j2pj`|Q zfOG(@z<9^~0^(n9LpTH98Gw&&@C%0%-0+U57I(^gAqoqA0~Y5XQGX7~UG_4$K?sj* z(?qh+Fc zERH}V-69u8hw9Jh}*-dg*q{yAZjngIo4budu1E|hD zjr?VR5r7o{?h?2(vN0;aL7>`^a!;ga9?8u*iZLE*=<04H>03}p`Pl$^ z*Y5$Qp^rw3+&T9FrRD|+DV;DEz$$c1R%6>7PUgwSjSSt6OE$YfE071hj=?h|4R#iQ zUO7OYyUaY^AeHU!1yFDWfEQ`^1FDGVugct!6s<&3JURXVpb9wvO8VtCy20UWW5#EFBxhd~+&pvl?BBLKTq9(CZ4*>KuOc@DC8)e(9Q>& zfc3!HH-)#ErpB#~jIk5x%AlJ-5GTLwhx=P&=;FQTBqdcV%<)xwwW3W8f7=@FG(bAqOrI=0x zP+4B&<3^S)y$?X2y%Ep|$O3T3`jm`F5KB{@MwWy7IKUk9_5{%^o|3O7h#lg7xuKWf z`v*MI%lG?;e)`oTVrB0{(Q7b0p5sh~c~Rzm08PnG)d2R&ibP2Hi#(Euu==(?x3@Sd z#1k?hS@=YU+?*^j;yS>`2-hz6Bx8XHq97^zu(%aKo2xuy675O68NfdL6~Jz@A1eS1 zJ}jq7Oxb7jJ1+|x&7 zh$rO%Ci{6zGB%2{;3<>xG$~8PGfWEQlYPbW;%zDWA$C74Kkg?oMshgT09pXCfF=NA zEY(+KR69tMV^hUkSa?&a=oSb39C)Vaxt|HRy9pfDU$ZXJpho&HG&Fi1$-0d%s<0lbtN|Imw< zy5&P2k(bC-ioL?-!Idpfctlwg6-tvYWr;G8D%-PgbTBDjc#r`@MYqtB_qDZu>{{l}1uG)79Wn*#LWybS%h zg8uTe!6M68WjSP&z)RH-diw=#{f+q8DyKy+0v88#5FluLFzi~MmIs;amll>(Xkf)mVCOxI=j`d9qWT~7KzYvy#1fj25lIyX^YX|DG;%-&MquA#ndPhMlgW10Ez+U0~A}MMWbRI;^}}my{0)g(O$!deB+dsC%Gu<@X7|T4GxErw*~na z`fa|9FA@D<6Hkfd&aturSz{GqzmEu zdlyAi={+lbAE{l1=NyN~k2vt1Tf|o;Dr+F5@(wNIO~%} z`J}T8FX0n8`?&joQ?{yiC-9ZPY39EJ=!TO4>w2p zC7=Spi=DL_)M+H6aLEfRMODgnhtLb;!Aemb zr@E7c$YOypT zitG{co~fe3$j11OO%-@Qm!K!jbr*2d=$0IAGIG=y(3EwCB2QQJ%8KctT$WCU;O}J8 z3{j|k?~)T{h(%(y)MtoohU{LlY$i-iL9uejOi^gIC=bpQ(~N8!skw6EEYY8V!nGKn zp#e5ah_O7Ciz^ z@%Pyx#b@`zRSpMP;=pG(@KOgp#DS+d@OTIQ_0Iv{NnefZfg9VE+U3Bna^P!$b5?Tm zOlxwq7FjfIQ5CJqQE#My*O(08bLBV~`dUJ=Z9*a)JYQG~kQ&C19QYA^v+j|1ord>l z59!Ii>m0@F9Qb(-e5nI3ci0kUS9C~M<$1Hl8}gym{n4_FEKGvH~!VZfUJ4^)@{SODk( ztOHyCxEOF5;0nMNz%_vD0XG3|1?&Xe3HYs$pD!0_KE|&>7BF_9$Tbo$7{DOm1(0VN zfJ4CUamj23u$xXgX{wv7$8I(Odg4XD76rEhcHs=%N(k+!Y{dvN7eK*Wo2fXB#qtP% zQaoCA&d1Zz04e8-3SSKRL@8ALSpdyC3BbiHwudstNS4L*P&V8ui|?T<+bT;4FB@Yt z$W@p^dxaMoW$Z4?676Mj^8&F|4De?x6bT}g5kOht3giQTzH;9ZJPh_mEgDM)&ZDQxJCiUPdY-J9KA@47O}E^6|;x5Cd)_2eTzk5B2B2ADp`KFSj_be28o-2O@Q5igMe27 z9|GzCK_!r%24IUT0X;c0X-d4)XZKrmtj-&o1WY3N&6#4feDO^2N6}wyULqD|r#MC< z3l;5S>6U>dcnVFI`dOkmvyX$@K6Y-Iu~bZ((HATn=6*=oI-O!7fIZ>06wnAzL&Kn& z4Pfs%oI#D{zNKQZ7-yIg+P2RVIFMN;W*hJR=g2+F#NpAYR%2;aV-(PO=t-RNL{tIb%H|5BUm z;J;~eqSmj zXIV9XOGpHO7jg1&K9QFx2a9U3KQs(4;&T8A`oZpu5lT9Tk2P4TYPVbY$w++wp&z@} z9mi6${@f=r{8}we{TNk)u1ou612}mYS~)kVGrKtjz_81fDBX~1(bx+0Wk2X}=@<_q zDoK3>&cSffxI$Dnfp}6&)Sb22d$wTLU$sCQB~vTzeVI~IrW{eG)cPy{2Q6AZILPgz z^D?duK(k8va^TMb=u-4QUhL0hM$U{`%+j)v07YkgjvMVjD-)y8VGlm0sK5?=Uitrr=YTfiR!7y_Wfqyi|H^eDN%UNjHL zKp!iB@@nA?xXB{lJRs8K3a=P7hl5vWmbth|=71@@065J^oR`~yf9BXS{zKmLtndt2 z=O8Zz&hZ~8u4^5lzp*A+p4K4xW47){7r9G@ql5-v!!dXlk_Pw$&$}l8y|L*_1@KGE zO@IhUiU-he{Q(?j)~y8a;)aYdog1=D|FH&fSkndxebwkR`AU;m70(?KXIN7oIdqlC z@vk{oL~7~vpeUe8a{)5|3+2%^u|f8373awJTST&dO{>@vsbvX$%bi2yunzI2@eCI2 zPwGTKO8*K~s7#KP($u7BQeP)JjbaY)$;F=aV)ri;A6YLN6WKEkh2hEm#`8snCbIn- zFA&o-F~xu2BGIjhIO)4YOhdB&61;$!Dibcnp>>X|xKwnme1XUb#}l; zai-CMD7khcPMPCm_eQZBeO-DP4k~FvnwdbSrk~Igr^>CDVIP$%yD!7(xG^Q<(aZ3B zI7KG?N^C=N&#y$lD!AuzuuhQ&FNY%U%7{%k@y+#@ZGw{NoM6fnoRrZ3TFfK$E5t6m zVIO-X4%?>4#a9BGDoLQ$dU@|>%P58Oivtw z0p@m@l5{!iYOyOZA0+nNB%QcgY=*c^TgB!?r2>6(sPtSTYG6v=H3HuXPLW%$#l~o= ze04h7ExJyO0;%pgu^&mHE;i9vx~LOze)sh_6b7~U2GIyAy6Tqq-5^%7=tk^PgvVcT z6QUi;nr}8(4&N-=Q%cb$yG*aA!c*nKTSS>wV00!;ZoftJQZ~FrR6zd6w}{3#28nz? zj0_CKhgBC{+e==wO(ZA&4il4u!{IP=$d!+66BAMyt<@lg1~BPX;kJb5--;oDk#EI& zswuJ?SmL9QMU6~Z$8N(;!o$lBrwunN1@trV> z7%q`|k4$<9Mr)H54+(ebQj1xIO)}1v%@5%-;!nN}kDhNk@PA4FLvZmY zmRu)KASp-&6QkOx02PK0e`C_PrYPEP<}#o}SM;%C1I(aUV~2Q0c8L5||zWd5VVGxAcahz6%PZbqmD*TAVLBW=D# zV>P#2i)!LMDIdifrpce199#sH?wRu7qr$BPj>!)m73YdYa^Yj>bE$vrV`3qv?}5j~ zzBr_tpMee1xr9(Id&xHI07l&MA31>VhvVc8e;0>SMuCTokcIn=(X!?_d{;6CsU2_(P^B$8gO1&fEWND>H2oi_RAR*<&&P4*Kd4;`Pc0La&l_04{Ctbe!JVHcO7%Axm zQJy#nB>ITi*5Vh0C$-v6LJ_Zg-E*DW_bH z;xv?mI=1zYs7aX)5{I7A&S=mdI3#98r0^qI_Kr)KNniRR!b!?Z&>0bfbh+y#u?Js5 zEPPp%70j|~EeFT5fJFd?1Zp?iUMBavEKa1%0g1!l!Dy4^H2Ltq@MJVc_I*X{iJOa3 z(*_5Cg1X^V{5i$EAa&QPc&MKv%U(lNnJ?>J!^7MH`Q2;Ka*iy19Zs_ltRZu^e<0ii zr`t(rkyoyn7+q5AcnbSKjLoKkoQ_!lt~ylm47&*V@#{FqT?A6duElR4w$72hH=yle zl&}wTeI#!}$)@nuLk zA_gl`UhEQeJsV}TzbR(l5i!^361zfgR?~!^!-l-O_)ScO8oBUI_|iEj;iNJJY<&|R zTk9lc$T!{;y%JZPL^t*-^kk}87gk*O7ETfBog`0s6gX84Z&>j*)Q}&cA*^1g?Mdex zR;-O-tO;*J_{uPnQG@$HRfCUDp^j}pjqG#nB(Urrf5w!b4z!Mes$`IooxM4$F9jv-bB3-e_3dw8LHo*x{I0-yA3d>`L4cA`0sXQAc% zU3C71a>!8#n=sHt5d8-$x6DIzj-{GnYavp3ur3XUUuP$Q zmDm5#;n&+m$e0iDe&~FV=n`|}!Vg7$0rjCC^k?d#{AvT}ie`Gyt`EhmM4qjNyz<0{ znDQ6Og&$%6bCL9aBsM1cz!37sX&;NS!54$X1%SH4V8JFX0X-D#c7QeWQX4BL!NxEa z!zw)04Qc=uUX)DsUxl$3e8T;gNON0ws$N zVe|X`vgA~DhIOy9v&gYuh~jZq+eu*Il>^|Gn9`_%>ho6ch9=RDFR*s%?n_c zI5B6-eJCDx3%FJ9KL?pAk(Em$ZAZ!5z(W=JQb9TM=d$=4tO>Wt#oyq=w>k2jZ-mFY z5=?|904Ek#ZSHQ_J}=s5j+OFkryjsE>XZrLyqM=p7hY6^%gkf|>7}3xxo-o8XwbLf zOmVYZ`ze>!T6qE<(4`5yg@X7*EDL($QL5|mX za`$)mCML@w{Xgj7+VOu>VJ5epG*G6H&kq!7Uh2(`R|42^c9I>R28aZ(!!!atg+`&5 z?EDXna>5u33sSaKD))Uaa!1_$3)OP1DtxoTDxEUv2OL$TeUD{Jm(zZLBhHrXKZxcj zyC8)gNJaSWi&ms3a5b&~XaJV|2DB=qyef^mNxutp{4v>akuhTTzhU_;=bLhR&uC?e~40FP+yLHSmsb+xT6 zHMK1*?R7Qvt6N*wn}pS?>TA2ac1mqWNA3EWMsHV5ZGC-*RV_$sXlbwQvJqn*`lowW^Ks$dsvQN!iSW2oypxo%K+Yi+Z)W{tPb5@n!9 z4^7c^?X9b7JG>_1J#TewiK>41J1G)s~Z};)<`t8ceK`qS+k+VhastHZwQmo z)Mk)uRyVR_Ly^@+9`k=js)9v~_h$5cR>a>YLUCaiHFHtL!M+Ztn;q zw6=#yZ|HE;XsLG++QXD>X>S}^Vo5Z|9}*kvO>~~u5oV`V?Q6YZI&?O*h4DAFt+eBH z?P2Bs8dls@8?5c)%mN-(Uh5EF>yTG#6JX3t;H6>hdz(Tgrb*AUm$unZ+P}qXFKr3y zd1F{vV_2E#6=Bn$uBEoKv#DXdU0`D!yh}}dAm^=as%usxwhvle`|38#gHF@AKnPA? z)>e}l`PQbkcFUcK)t+m^8dkToI7kLVO=n9}oi%q*$xyhitEruHlI^do#qg|dgBM~x z*S4BEG_^TqosCe_(9zx+Hf36CJ33d^!j&;JHJwf8Tdi>>h1tiNTA>;1!#J7KGB~x6 zDJ!jM^I9|7L=jJwUM$6ovZI($b`%rJj>5a`XlENC{gE*$M#+0@Vl4{5OG zy~$)!JDM6-T4Z@&KxCM6$>gxd3X_6Bg^XPh@YrHZkn1Fx(}L)~X)}i~U&yR2YzurV znz}j}w@#92`YuYy5tK7#RG8g?+U*Y1Zg-$|yN?;=VLD-V;R5- z(AA`Na*7%hYwfO}jUw zylb(1STvt9cm3$FA#VlFF*eoX^Fw1x`wDA44G}xB7ss-V{nCmSOHzlIyNwm=yS#P5 z!NeBYcvLZEgsRuAc6W4mu_Sxj)--jrx3wZ~mdc_i&3Y8zR;8)VeAqDyEef`oR+|=~ z!`tGmh3|zo9xM#GUi*r3YnnQ1R^aie*%V1iSFPHz1EEv;!YB^z`qis!RXbL<)#16p zq_otYkNs9Vy1bSFb8T&h75j|>p`>7 zMU2M`3}#zn*GjYLI^$_2Y$z?R;Qr0RgL^m&w>{ukl<>zUi-aYwA>+5E47Qt?g@+udVly&{o?TBtXc@`X(y?ksr3MTWgKE zg~P)`jc~wgI~r{iaCLcGxixJKu1Kue)nsp`17)y3V?(%fRBUT#vfP*T;0E>B{B*z; z?H$(X0JihktT*8C)Z3+;H%MDiTi1LN5mN^Zs(7e)eURR{TIto{ZG^G#Fh+~i+nJBeF z1zoDCt6f!F*VJW+tY6=Tz=#+R7eI)#w(N>(u3SN~tc}&uvW)drabPz>k85q>F3N08 zUKOi(`iy%G2X=qP=_U?m5?+gSMep@L7OR~qD*M!&>+k4%j`XP#7b|=sv#qc#G+Z)HD;N-AxSHX9a`1VShTRK zUG7iPM#LplJ#Tcu<^L&3`$?Rhvus)3vSrJ1a`0bKaZb^)+@hjlz%pRWW*6lY6=fF> zIepH&$ukz@6?e6+%FADtpKsEa<()od&b;g*#Z|q&acxtZys(efKi#!qM&;i8I=D$u zYm4iQc|)t2om5*d@9LvfiZkWWKH91Mgh;P^UhvWc|86I;GH$la@2gGd6OCi*1pE?> zAI@lJ%g(;qsN4vg@kQWJm7oPv%@ud4*)h#ESU%Mk{~wf0`9WW8q;&Vwl6`zD^0$KdVlnxNsBGYV(?@i_J@L`y~ZyUPhUmp%nwImcZZZ2;Q;`#ha1Q5L$-Q z-vYc{8e!EbM~#u-O2^xVQ-gIXf^|&E=`J5Dku4p~D$x-^whX)(%Z7Mz^+J9Ce!Xxu z-wP@aLOugNQGz>ve4WA9G`#a?HenEgH`M|^xG ziKc)g{3tpSVoZU(UGbpxaV4PXUeMbVFdkp~_Y;hjCT=!CJaj4L@qMeMyyA*9YT}bp zr12G2ADwK9*%YXRnf3?-`Whno;tM~y*{xj@eL4=BI#$U6{k2bqXO$VpW>{yj8?4VV zH#b?M!iZetvC++v#p&8MFt_|>A?{d8#crOs;`Z@55>u&J_{^jMb0$&Ec2z(wm z7WgdiY2cH9=K3h`Vc>&67yeDb*&-TV(dGInup00q{t?wHw6F1zlwZ z5%2mo@Lk~hzy=uX3+*`m@zp-yT_pNOjE^`GI7h6>Uu$QyW*}lO~Ajfh{6=)XNMsxo4I}#rN5j%KueW-bG67Q2H*tZ?q2+N8iY|j z$|XAnXa#+)*9=$Z$9t532rGX-KuhP>#)1Br-TjS;#L!EIYrZI+$ z;kZ{Axk<*IqSS>65!X*HZEI9g=T1{v>y$}#)@yB}-25Ugwb z;#I~qNZvnKE0zZbYL)WyA=(f*BU8JyVlYCL^Jg}w?)FkeQ)!Ic14oi2gSGffJD<5k zk!z6g8D^znEZXFSf!aKux#Y7rl;c=bVZ3vD`0@2;_%$8>=7RGV;uwO(!1=SaqRfc3E>{~=GZN8|5v#u=td(N8 zxou&;IS)B!8L>haKSc5v&Qk#1@!%>4oQl`emH5-gYU5S?3{!`BgS1HMfPVv3-kzh4 z^QB^54}?VC#~~d7NbAAZb3w;nY#5x(@iO_-KpSV&9fxRo@-Gds%=t6x;~rz>s7#R< z!KA{p(W=2(zgT4pd4Go1PfK^nokO(oW>nibSc{b(4c1QaF*s6;yNB>P)F`nUF%t5c z{3g}xKJ#XGdJ47nS)%g6&=wzxaz-e#!pTHAAYUt$Glyy=@|=8x;mUk1HZmHm%ZrC< zqvqye20MSIM(S=aRWy}OaP-T~6}azEdzBE&1U#?subow8s4y=d=AI}o8Hz>1(C+-9 zS|5CPqF6$?KwtuPyc4iDKKVB}$gk@4G%;0KAYhNhDsOAa7sv_=`k{)7DGSeD%ohW) zPKvaQyhoTEG314Q5y+Z58@O4#FJwSfVKg2=oIktR;;_q&Fw5o2{WY?svyq!3vo?3ss0p%Dd#W5&z!xq!X6S;KAc@qnX;tHF5a}{ z^TV{>N#T5^jc+W}9uZXr6S6b4xa&FjhbP5bi?4=l7`|5|u|NnW#TL(sh@TBAtfy%sBIzZ>g-8;GxCu#b|BT_lk z)zq{bhj@JH!IuGEc}lT1N$xMwQv4f=wRdC0czMoPEvG+U*wohHEHev7PFeV51*fOp z`l5LM^0C@OqR+k08&~Dt%3Pd{RSDNVIc%IZ;Os4xRg?Bs=2fG1l@Ban7*dUAy!N&# zA?8$8?XAoQietzw;ANEtFB*V=uMFPFO^rCM2KtxEs_MymD~C?S88lB*LHbO$jXLX~T}q0_?kI8|Q>8#v@_TkObGR$ z-nU1NIt%lsTHKQ; z@brSy+VK?&zBj3_o{Hi#3eZ@Mm%dV6RXM48@1nvfZS}@C1F%cAytZ6(PpzH;&NFd7 z$unM@&3E9v=-TS(l((da^^LbRIFD{>ubu(cvx=(lofp3$vYMU=&ZTmBoR%S~W&8wf zu&?y`h?;+0eB^Ie?kT=|+XFLB-??*$Y44J(JXh@91vlii_1&I2EwB6Oojdbp^Ucb@%m&0|7#vIZsC!hs$EK2TOa@@D_;UkC6+IQ`sm{;GwaR-X#@y$j<$zzuu ze0*KRpo?xAd)34%U- zn6hllxm({@c-!q+-@N(YQ0QO`TS@M)%f7nv(~*&xi_YKh?aNDVMqlRCHno*(_5H5T zrp(1Re7gOqD`Ys?mv&ea5GB`_b8cNI{eCh2`Qg+ z%ISLVb+2Ti#5{p6neuhRb5p#P!d@C$+Dc^#O-QccW27X-Rs^)kvWx0(hJUgX8Mo+xW0bD)Hzq^ z^$$XE&bX4qq^y7bYU;&*x<2)m;=RwDR!cf&S4rt#8`__Lsp0*#FW)%6cF5%IJ9p-D zI?y<)#=M#J@Hd6`fANnG?piQ@=ld|uj5Z&>+bEe+)c?q;Cf|z}uU)_Jk!L?S1IAX9 zu_W<}Z(e@)!YliBF9#&O^;*M*qaU39P3Qky>i5BW=B_xmr0b&Z zAJ4zx#t+{4=yZ}YA3c9xv?{S{NnlZIS*X8P3lj?cSv3|la&lx!RI!@b!TEG7J zym5jTV`B!GlFYMT7(aIWsSkX7-)+}?@=5*zl$g~@R{itY88iF-c)aXyZ~Y)EcIlPX wb0<&1`TOk2v*+=w*fn|f?1fC{B`uhNPr&OJQ&_=giY*vqoOmUBD_ulViKDXUsvE%?00Izv~KLAJ*0A8d? zt^VEWHj%CF7V+XiwLlqq@ivqM*8ZbG>s0#!v`vOYXpwN=1?1eXZcv6MJbZzYM^KWg zE)0qne^*^W_3ANCu9{w%F`Gf>#j;JRJ#vvD`_stYVyl`OY)fLv0l)%4i~(05-Kv&E6~me< zqbkK6>XE2L5oY_US`u9&4ypG?J0Y!m%p7r8b;j6mUmxSXn6jb)rd(Q;c(Xw}Xy9y* zbf$5DD!@yst4peQsbg!GJz{DJ2txoV017kl)Brp!08bCVGfZ54w5ytRNiMgYTv0K6ms9}?`?x`wmCj88H}Z1WQ9=y74{nCV*=S|h#5NY@+bt$ry7eF}hAcR*Q(wa2y; zajIkgkcx2il~M6(N=dZns>+ga>WY$D^-N_CbyaD+y8CRJnqT^~8d(yrzE>6x4(E;{ zbtL%bmo=)}w}-2BWxXQk-(3MSJIs_q1{mrJkLZD*CIo>6v1fS~A@##;UWX zrw*9)v&Yj9%$y9o76jlc0`QyFZPQa-PXtik4Zy=-Qh%v~1MrCfxIF-0AAq|%$9;|k*H{&%hF zALiV{cs+Lx?wjYj4C=sn9er(}HOQb4T^bnK|I330UJNcH^!LY%d> zn3q5|moTVMYgM<`hUYTy_X1F=4M2$uaa91;;H61K4XWDRv2_CLEC$dHtmnT-cr^gs z)Q+ilu|Pfupvye#;9`{8&!(=ayAiqAdbUwsUxCGVLwz~&_60We>-v7;W%Xo=RX&s` z`f0>s*k|(sTb8L}4n%S_<)w*6$|%qLLDdsvgTR6!tJXcOW zbS3U*m*z!;pkfLjRPGoovgPj=Vpcx1JH8v|IL*h44Rx_>OiNU|Jet<=%Cc`nI<3Wv z!N{~SH#y8}6Iea5yh41Wmbg;YK8t&+^H=wZ>r@WDnd+k}R*KiaQ>5l!c}PvUI!7d_ z_SLqSPMqqvmRV}w7181yP1=uF&&Avam)d+yw7TzX54E{9TokBVugQbz+gelAr=IAg zMy~1#>~w3UI%?Gvk*e`;UlpxeK|Qz%?RJ#7_A4D-u3ar$vpxEf%jGi`L>Vw$2z3)kUD&AKze%MfnTSicxF$|K!e-r3Gye)SC0m`x&?*ZtagQ5heA z|EgAApEsDzaq(UEi{2ck1qXosVm3t;*d%F8BUI;0)`)lm>n>Bvg*AqSyco=5JA!Tq zQ^ayLYOPH)s@ZFclNn0r1JsPm;2Z$k;Xv1^F7P=zHm@xZ;x_fjjW%(E`q_=e$=9IJ zzfzrFC6`)qlTEBr=iIcc#~RSNwQ2M(M_!%0rdLPky43<(Lc6f3+usdWA6Xv{Z2$UV z+&%ARswp@3;554#n>%&Z&D;*_`8_umA%F7bY|yQ@FwC{yax{+9imh;X^=UW#)?$=x zxU~ZJcW%wYJ#0e2*=w@ISR~kC(5B@J{iEFWS&uw zvzU2CLe4?v*@o$D#IYfC>0@m$^e`AqC9DQ+Dnk7!z*L4o*z_3+G`+=Cie&^-F)Bjb zRIV$-6A7k|U%@xEsx)N_ZT zU8_K%f0hH-Pmaxa055+U4b5gb^)3ahF!JOdX5{_(3qa%LPcvmOo>PX?Vi}8KQlmd7S1oQz=3cC;lVDq$~f0ww^ zq$${?JR|R~K7ERHO%2h8dP{4BI&E=$GTU1KFxzIH)@D~N>W)d)GHPgQLM|GTePf;} z$A@6@a4@JHHKMjrs_n5nRT&wdq{#$@7Gq87qv@$uF1CiyBC+b6$5Yj7C&ovZ(xTOq ze@yMDek?pRq7)3g7N|QuwRWugb7RQV@3D^~i4v(#KLFchZ!-h7RBZwH8sOB(tiyUz z9rtvF^57Zuj;H%7Uz|~&eL7!+s3)J!#Cp?xS0>`!&|R5R|ANgJN0`0zuN{K043c*Y zhF}GtHOw)|HdYCGwtu~c)uVq)btNI>n^Z~}5P(kx&Q>{@O^N3~>jspasU|sHpr{H zv6z|)xPMab+LJQl1`YzQz=+6kiUOE(KibGMrAL@^o_x%6me4ntkCgWh6PXco8fp|F zW2H##ShM$mP{suH_7|>F_jQDK3_1Knu&ag)08`Cx0@Qrjz}YT&=-1C1BgXbj`;q=F zMwUUqq|sL{f(@ygKdstlXBUbrmg_+Xbh6(Y#%IHv+H9P*`km1@X&h9Ro5ETCC!cU& z7RzS=xIlfAUvrbJP6Uf(B5;ekXm`Cfoa`en4kzchX{X-@*lFo69pNvpP{cs>x?@Ad zp^iPrRBqraU$Fz(@ybxF*Bzg|TEJ%w>l?GMP&?lkhr9a?JS%j}d2>CPKl{fKARTW- z3GsZ#{j?q`> zG0n)n5q}Q2fB8<}^fRM;lw~al{tC1O;Fks9o}f|Rrm2(>2y@; zz>5)s!#fziJ3|u=7#cu=hcUnocwX&(Y8?7E=Ty1TtNTyc zjlP8aSdS9tkJ!6)WS(9`7u)btJ&@Bs#S#fSlc|P&frH#L?Ni@DoM#VBA7}yY?*sL~ z*``@OCV>Ai))>wev-}aY;A~0cMo>6|tTz&c6)#|8d%-FG#BLv#<|Uw}dI=GB0|0bU2B+!-q}|37)OFEa)A(ILm2XG5>KAiT-GOBC%u5P1zLx#r2`VBQxT~N z&rlRDva_-OQPKodF(kGBrlf?Cne{%3TxbhD5B7CfEMIrW~6A<-bi&OZ;KQqaof)0J`J+m z6e+rjjdENR)cK=a9|aG4L~e`1+r)M9NR-HqSciJ-V!FCN!zL4>MPU-RT3kje0gZqc z0aRd}v`33#5h6EZ-ijOL!Dx|Lb^rxy0hBQtPy;YKbO`zD0sR5f04(QFut#iw0jrm+ z{9Y8u%VWev1GrvuJI4A_~5 ziZ(ek7D_^8BuU;*q7vQbQGjmJtqA7nj{&7V8VM=e$po++>SB{yPYG)>)#vg?kE4{w z0UXB+K#jWNm+ai$$Z=G+0|Et-%ajl*W4j{6Uk(yud9bt(7PefPhP8JBI4Ato=>t3r zz-x|l#)*|Ne?r#WM{Ja*<3!QLe+G$~br|UrNd2b{rLz1<01fMPE#!k$doQb8)lEF% zdJ3qf7g8$Z29yAJvHH^h6Q|PVm>_G3!V_B_Gq{doy7=!0t}$?`K^{)G`~aS=c+B!F zK!Mo+1;nVXrc@WJaM-yMB-QKzQ?r>M@<0VzpKil44xyRSr3fPdl*NltgY}04b^#bE zHUa7ZX#j2v58{bcB#7B@hk(!qy8*fjElLoJ#6kIHg4il{$YqIwhhjLo7JKB$M4Z{v z8E8$a#!K60B4sD3rX8?d7F$t$uYAXfiTY1>Y7g<55YNc4p2C&27z~X7P61Znh^7N5 zh-LEuP4dy6BKu-53KF|Sb`~!J(CTKMCZJh}Hvrh9eKOW2tVwkS*@2WSX0vBXv)!#rdr#1Z{4G;|AqC!*l0WiEU zP%s+O1@i$MFV-6m;Ebcm*&()O(m9(lrL!;M9c@5Mzho5mM#?Ko+B<|*%})=HqizQP z9AYgmkK|%;c$q$HmFIFrZ*5aX1x5hQQ$QB<6-5#30~-!>#ZyzGU2Ok5T1E4;< z<^b3q_V2gF?e8nBc+2%>Us2-%qu0qVL!QzYi+P!PbBM17%mlEzH2~A2IplN`D!v>r z13;_tq86My{&G#NSRd95)yy0%k6tcpA-ZkQS!)vYLbTFii|JX{gEm60#Jjl=&Y{1n zdFL`+{-elu+8klFI}Q*EVEde%*8zBC>xnj+reKy)f4VHM8}&pR2xd)X=mBOOO&Kn= zY=jq?XgGSWIUHl>q4eY;AnnT+;R%O?Zbp+3wInxB zUOPynC0sDzNcSL-I{ahQ;G*&gfQx<}fY)lQLH_unfGzY08MRQP_CFDDVET-KbFjk! z3}K%FI5cm`wL>uPK9lw?!WP3u{{`R@5vi7ZY*kn6E|i}R#eQwbP|?-p-*`npD~ZPD zoXT?YKZB!lfBp>t_%*<3Qj@x? zw*EvpEz1ET0W9LheZv?4{g+iqkCw}ZVYC0maFG+j@(kHJOstjNMu@9i{-byw&anM) zekHd6{2YkG0LmH-NH_A-fx*)BKU!)k>X6U$oD$$17!&{YC*6~1JE?rj3!D7jxL7UM(284jr&SSDT!sXc;ZL#1sJ_O28bA`2#nOxZjMPp-tnSd=MuPZB*M z5`b$$A?ctHH&2p2o%y2U<$d?$3zy*-~78XEufqS zNtBVQ?uoOhlaF_G^$g&M4Zwd6SiQarz~2qP4+P*32jKU0#?@U7ajr$3X_krrd~^Vw zAAn~AXRitYre(qccs$0c%5q-c`|uQv@SKmJ;ZFglqh-m;X+rk77APZBiB_nGjCkZZ zCu875oRb4WWZ`s?j|19*8f?372C0XPog<3sl8_}N1NsAs0hF`>&<=P6z%xg>Z*RZ^ zz#@PX&3zYE@pJiPyP}a{Vi@QKsx>44xbJ-BBL90>N zy>p>f#ubze#`~Aa)R|&~u(@~46j8!O(`EuVNH+pJfZhOhnce4-$JN3#4_8m>;{><> zkgS=C{N&{{N(FF@@Ly@^Xl#Q~B>|NvZzCU{gOEuBaM`8J=^b<+;=JZa>t&)MZ2UN)WRYg%hL1GEda3Oc)H$~U}XM5n&`E7M>I;_^(Fq56XW>@)dn za@=ezCt=bxTe!zC4CesYd4Ee&O|!}WWa$_={c@2#z-sh}gT{6K-}R^-<-KKrUEt6} zn`|<2ju<_O4~PQ*s{mU7F941KJ^|DKOieFf5Up>C;4!C3f<8^Yn2%NS>v?!tsmv8m zh$QKrE2gLS2(W${D$-DNFdC_c%$p}v(Npf9Cl)0q1#q)x9CMv>+?tr4WW<^X=HCAzz5k~rNY zUsvN~YM|aycfF+%RpQc^>0qUm=?6H(vLg=et`d!SwVPcnTxGqC*27W!-?q+qZ?+!e z*ZLs6^;ouEJT(Da=FlRmy`5u9FZ!*1(Vb1n5y-DLcr`iFH64FF`1R{u-P>!$MPdfy zKo0585*%3UQyP;eS>6cohYA5&!bdwGW|~>fhx}i za5@t>TiL?p0Cpi*J(*@5!w|%44B&b#r|Zq^SU(z#K|`@sI>%@L_18Ud!x|h%r7RFH z4qpcv`LX~CfEW4LAC@s1^Z^6`I4CAPNTxQ3MM){BTLLn#M&5vHEb{&aQ6U=S)*sMP z^KKD6pZ()fO-Yjic2mW`sWG+XD42ZR0{DIk*vjk%&Jjoza_3-?sBXVLTy35aF25dy zult*^*IqRPf3EOSucm%rVgnT3gfDhl0To#Prva+4uUG*12jDp13J9$SgoBrpm-EF0 zP6Xxy=Nlh4=tjc5w1F?T4k3T#cjeax88_%aO?y7M4MNTzaIa5#jEdyYM;+)RlMR0gz_QR$cw^UhHmB z%hKPAYz3~k{vPxLmE8A=dL*e^gfosSF70A=dW_t<1!LJ?*XfHb_~K`*JiA4dKzi|3 zQ6Iqp$_9j~v2(3zq#7+pt`}Wn9>M(On9-@j<%zAroo_75Vb$Hqjx^>=0>k(-Iiz^2bE9 zd*8z%N8sy<4UdZ&_ryoU`$7yLVsnpu48|1$-9Q#8czc30)!lQa$O#pL+~rRR{GH2S zcg52<6cy*e1>mm$XYUzIS%;eMHE5=c zEwbcU=ytWNc@{5n{vx+NE5`Nz<~v;-x|YfK1ZYvfsX7-dQ=pXHpA(r$E)=sZ7Wefl zJ|-)l6V`-X-|EHYc(T)nM)u>Dkn><2}&*cd;kv|@vjFW?L z-qb1`G_%>62A$mu`bJ)KKr9rO%WVhHy&>)+2gG#F#?TxtNRUSQ# zPc!+=sZKq89M9cT<=XcVeP&4a`*_lsDJwn@Lnlx!J+?Q1O9B<9{8^xT2LL#)3_a1- zO#0hp{yg%?2MB;u`vSzAL4}Za*%vRzV1U&nai52K||B1YN}_RP$JBRXaD9TWlh%Ez2|+$JiFWTT48GcN0`p-xD_Z556L|1lq32h9 zDbi59^-EzLz(c(MG!d@$=lPEl;hIj|mwxSNPZf}25Nu|7AnmEabC67}Ospe_l3B3hTw~ok)jI;TsB`Z!ycY@>#a_fJD z|84?FAL%_micA;Jg1sEn6jwIDjGTA*3)M>X(cm<=`vPTsK<8xV#mWAA@OX`*QFZyj z$milHdfsUZkea?xR&7k&DZh)>!D8ikSH0bt*_ zpj622KZ~Kmw}9R3-_IaZH?qzI(0*)UD|o1DJ5tm0ewNq$jEQiceDr5A9rMBSGrl-r zgqaPf1+Y!Fm4-^ZnCHTv{d< zoz>dhe^yi`u)kzT2T*yw`g&dN|3#!u;6W3C-R2>C8u;kuba8WuXhEK1$?8sksj`AR z`8d6!WW_oBk;z76d8Gl^64jdk&_v6EbHZB1r&hMea~Zb84ssrj1+c|207|6AY0>+k z5nJpH=mB8fzZq(#g-E1qW{5ogtH|vCz`v=MX;h&qtg?)nWhOj$p(?We9LBIhZa60v zjd=(h3)lu=o54-va-m^=Xc3k@3|bjdUZvVyr~eW3F0#ZUYy%$o4VFhiry2akJw{%+ ze=nAphdlUWgI&_?5qZgtI0d3Moc!s48h~l33hD9S(EoAN^e0yutRs-}FlalvPOE0AaW*ZkYH?T`S1ze) zv@|>0^h~3pwY6}^haYg7)YmHp%l4>K@w4~9< z)ix|Oa*nGO8@akhm($r|B27-SeqD=?r?J*A?=)L&bk+|jG%BK=sblMvEoNU9JC`|3 z(X9>51}}08jBJe)io3M&N7kgaRhg{FnZzoefGVw;?lnH%Dr5(mavcq3pB+~kv}SLv z(P5ApHAP+UzIu~XZ|bg_+H?f3;j5RoIa)0>ja99!4Ry;6IrTLdElR1e*Ep9n!yj6i zr!%rhPnsH*x+RT`z+48Z(e15`4K)s35`3_xt-;xBSx^PrENRB*!7Hnp zEDg;*&+^OL>sp*mrr$JGwX`m%YP4epR@qw{Rya_r4eIHRZFrUDhOT;x;eqrjK+!-u ze9OpTvKl#fl#zo+898{ANpqTfRn2A&-PFZh<;}G&XsBzmH#+LfmRc7?lG4&pzW`Hr zOQ>RV>2=`rK7BA{e28~C=!_`SXNQjZbrBuWduFK7X;uvxWcCs{qnF6FE^%nxMAqmg zaz-~v)4PeB(M{y^&LLxT6S>aa^b+)5LeC+CWLYGll$PcEMutj))7MoX{$16}yj|5x zQKx8Nr}2Vu3>Z^vtf82 z!E1aU$?I!Ak}d~U_mOl-ok)h2bNsjrQ~Rnxl40(eDw!Xp*yJTqN>Vp0B=#DtI?ay8 zR(oSZE2fDnO6lRMX>_(a%o0mYRa2vh==1$Nihal+osG+3bwhJi%X0d&LnqcXElh)>>zZ;yece4AB%|bozEz(7{)?le=Y-o01MZe1KXs&0r*|7`( z%8NGD4mO8{S&jsji#B_GqqEwGua*`E7lR&L9BOD#Yznk(kj`U~$6}No@~aq_i0ec{ zja@6Y7zmbHhna72XtCN^z0ls!YOls#YLSIVTUEW5a_G#wue5f_Vx6mHNplVMBbLUh z70W3AKDMl?rB=u5oQ+s(mwAa8YdDb6>xO1%gY~Gjp}ra2LN99@9W54^TlYzrq`AIr zfu%;<@R$}c%DB=QS*~_QR^K5Rh`xz(!LaX!ss=sdTIhq)Cn;6_E ztF6J1)B*}uaEHSy1dPpf4fPryEMJSIs0I2vTb5g}&A^_b4x33w8^+&@R#(+5^2af* z5Q~`z4wqg7UbX~nwm9n1H*C?^ms(@1y3A3v$gYpFMay$UwG2nu%s{Wj%XO?~fdfuj zhj`Kmv*;2nj^@@SEe?zUl(E-TVJFkjw%k%Xd3iIY8v+B2jfq!nsWk|CF!QH0I-TeS z?A285Z1nPBS>bRtH8Ad5OL zIG#;;f}wwH!9%PRd}0`@jRqe<`6z#pf`g3^oESs`>5IntX9D|YN(e7kHer2^wi>4&59E}6FhSPVHz_ji#$`2Pc^DE zq70`FfT>;~)yP$A{OnnVm(JSwVuQD9Gr#?LRlt0m&w&D;9));AEJdpL@)-~lPlWG)f1AF@N?y&(I6mkK=|#uUOfhs7*I?$U8zEEb)8GU55z&p#rW(r&rn_G zjY8cZ$nJ?R;8Wl=spv!jtfZMD7T;hiLRf@wg^OSjDFo0U(GxPLZY(GYj`5;JjOZe= z@GWSZ=q9@3SUnFqU2N%L@CW0M$kQz$fdIVn>)kz1rai6Y=*Lr|NhuZDv<(YOdXn%iV;Z)LKp=n}_Oj+T7f z8)^{A9W5=+7Mu(AvqY@M9~gN)!+-R3&hxhA5pf3pbJq`^?>*mnzV&?LIqCV@^OZ-j zobY_%`P}oXC(LrAa!UK8Xp$vMbhrHIsl}L|_Wb1e*)v0UJohP~_{Py`IVHYO&U&u5 z{Nl+{y1`Rtj8GCS?~B3sPH2x(gG0@WMAx94ActkVsDlc6u;!oi24mPgo*sbCSN8x) zBwQgM;fo=Nmc__cGYEzG$<(G>PJ#G=2RR;v~(e9a@s;dd8)8l&bGB$% z1pM=V-uhECLH-Q<+UNYAF3P<7my_mKpS{YA@p$}LNXpVoCMye+e%{<=^0s{C>JTj& z$j1tll(1|#J!icbqS)}wkr{jRa9}ph7nO-HrvI3k`DDz_LX;1X&-POiD8G;P0+@Bf zsmE}a4fYTG<-j?HU~w3Zo|kkg?Hp8eEC&nw`9EK%^_PBLUnYgTx^Dr$Nf#NLCnxYN7bk`XXhBt1mX4fxiN;SaSQ9vZntvP{V!v1=yc> zJU*Oi``6d`DPbV~(^w>OSrO*?*MpR9^4UR3sm+S*5sUj^Bg9m{$U0EIpRFXgSmf~x zHJD5WGwp-wfj_fM?>8}j(N=7<&;R*&$ZINvd@!o_;fia;f2yHNX6noPM@BQ>*&-&D zDJAHA@py_g%x57|&j0a0Gtz!jw8WpmNtA=6XTfG&*N>Ub9 z4F0{IjLFb_PcaF@4(3 z;20sAkaQ8^8YI{$-i4&A`>7J;b0u_QTH4iV&GN}n$|%w74lh?e4#TIRUrkgp+!Yo0 zrndi%W7<`^voy1;rM^s9c9oXxEX^w8Yr3+9$3X8hYDrz4qXk9lWS2=wuhOaH$S&tQ zgqpT8e3e%^YG-Nhay%`9=d4y`bVEH(R)Fp;Eh`_rvovR{@pK8&&vM};Wq4fLF^v-& zO_&2xhR7!-DSgG`^7tgBU*YM>llgrf(k1%YEaP^c@8Uu9!dOZ$GrR_r3(DKZVnd z4!&;a+A~AcPoiGD=j5)N+S@ZHRV^+Y`__%4;(GMo)HOF@>N8(Wd%C?{ca6eZo?PX+ zcKS0fZrWs>doX!}IfzwG zb_|~|Z2RSqHC;OfEPV3I+JAmNcJJRyrgjheZpW7XELo0I!K(@nzjNQB*BXxxJ2zl{ zT6^)K0+i^EU)b&WsK0)dUtiHPzP($|?QbQtx93ha->4K;cAxN8<-Xf*ee0%*0q^vB z@&QyE-Qc447uNg`{mf@eSKRh>Yv!zt+pl~GMVK^A&gR1Uy`g`2PL5xgcJ0XBe}8Ip zB@{2mk$Pdou4^Cs;nMs5+Hqgd*rL8mwvmo$Rk;1|lk;uoYBQd`_Os~Kd!N3cy*-=r zfX0c*9M<;6Hy=Kq_|Bc%em#`;I*c=+*@ZVqg$cKR61QU0mg{r+eevz@M)Z6c#x`eR zq37O757gaz<)3@W9nKGfW1c}R%_$2I(xK!%qWF5Pn54d0)#tXY;g`Z5~)6m#IggS=pnlWbNHy9ems=|X)xA*i(_QFl6J0C-WY|uzABt;l964E1h&?%dTr@lwDBV(=@U3O_1{)TssTs<8pTtojKau($6 diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 43586a52..873954b4 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytegen.ml,v 1.59 2002/12/15 23:28:52 doligez Exp $ *) +(* $Id: bytegen.ml,v 1.65.2.1 2004/07/07 16:49:51 xleroy Exp $ *) (* bytegen.ml : translation of lambda terms to lists of instructions. *) @@ -260,9 +260,9 @@ let max_stack_used = ref 0 let comp_bint_primitive bi suff args = let pref = - match bi with Pnativeint -> "nativeint_" - | Pint32 -> "int32_" - | Pint64 -> "int64_" in + match bi with Pnativeint -> "caml_nativeint_" + | Pint32 -> "caml_int32_" + | Pint64 -> "caml_int64_" in Kccall(pref ^ suff, List.length args) let comp_primitive p args = @@ -290,49 +290,49 @@ let comp_primitive p args = | 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) + | Pintoffloat -> Kccall("caml_int_of_float", 1) + | Pfloatofint -> Kccall("caml_float_of_int", 1) + | Pnegfloat -> Kccall("caml_neg_float", 1) + | Pabsfloat -> Kccall("caml_abs_float", 1) + | Paddfloat -> Kccall("caml_add_float", 2) + | Psubfloat -> Kccall("caml_sub_float", 2) + | Pmulfloat -> Kccall("caml_mul_float", 2) + | Pdivfloat -> Kccall("caml_div_float", 2) + | Pfloatcomp Ceq -> Kccall("caml_eq_float", 2) + | Pfloatcomp Cneq -> Kccall("caml_neq_float", 2) + | Pfloatcomp Clt -> Kccall("caml_lt_float", 2) + | Pfloatcomp Cgt -> Kccall("caml_gt_float", 2) + | Pfloatcomp Cle -> Kccall("caml_le_float", 2) + | Pfloatcomp Cge -> Kccall("caml_ge_float", 2) + | Pstringlength -> Kccall("caml_ml_string_length", 1) + | Pstringrefs -> Kccall("caml_string_get", 2) + | Pstringsets -> Kccall("caml_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) + | Parrayrefs Pgenarray -> Kccall("caml_array_get", 2) + | Parrayrefs Pfloatarray -> Kccall("caml_array_get_float", 2) + | Parrayrefs _ -> Kccall("caml_array_get_addr", 2) + | Parraysets Pgenarray -> Kccall("caml_array_set", 3) + | Parraysets Pfloatarray -> Kccall("caml_array_set_float", 3) + | Parraysets _ -> Kccall("caml_array_set_addr", 3) + | Parrayrefu Pgenarray -> Kccall("caml_array_unsafe_get", 2) + | Parrayrefu Pfloatarray -> Kccall("caml_array_unsafe_get_float", 2) | Parrayrefu _ -> Kgetvectitem - | Parraysetu Pgenarray -> Kccall("array_unsafe_set", 3) - | Parraysetu Pfloatarray -> Kccall("array_unsafe_set_float", 3) + | Parraysetu Pgenarray -> Kccall("caml_array_unsafe_set", 3) + | Parraysetu Pfloatarray -> Kccall("caml_array_unsafe_set_float", 3) | Parraysetu _ -> Ksetvectitem | Pisint -> Kisint | Pisout -> Kisout - | Pbittest -> Kccall("bitvect_test", 2) + | Pbittest -> Kccall("caml_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) + | Pcvtbint(Pint32, Pnativeint) -> Kccall("caml_nativeint_of_int32", 1) + | Pcvtbint(Pnativeint, Pint32) -> Kccall("caml_nativeint_to_int32", 1) + | Pcvtbint(Pint32, Pint64) -> Kccall("caml_int64_of_int32", 1) + | Pcvtbint(Pint64, Pint32) -> Kccall("caml_int64_to_int32", 1) + | Pcvtbint(Pnativeint, Pint64) -> Kccall("caml_int64_of_nativeint", 1) + | Pcvtbint(Pint64, Pnativeint) -> Kccall("caml_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 @@ -345,12 +345,12 @@ let comp_primitive p 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) + | Pbintcomp(bi, Ceq) -> Kccall("caml_equal", 2) + | Pbintcomp(bi, Cneq) -> Kccall("caml_notequal", 2) + | Pbintcomp(bi, Clt) -> Kccall("caml_lessthan", 2) + | Pbintcomp(bi, Cgt) -> Kccall("caml_greaterthan", 2) + | Pbintcomp(bi, Cle) -> Kccall("caml_lessequal", 2) + | Pbintcomp(bi, Cge) -> Kccall("caml_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" @@ -409,20 +409,27 @@ let rec comp_expr env exp sz cont = (Kpush :: comp_expr env func (sz + 3 + nargs) (Kapply nargs :: cont1)) end - | Lsend(met, obj, args) -> + | Lsend(kind, met, obj, args) -> + let args = if kind = Cached then List.tl args else args in let nargs = List.length args + 1 in + let getmethod, args' = + if kind = Self then (Kgetmethod, met::obj::args) else + match met with + Lconst(Const_base(Const_int n)) -> (Kgetpubmet n, obj::args) + | _ -> (Kgetdynmet, met::obj::args) + in if is_tailcall cont then - comp_args env (met::obj::args) sz - (Kgetmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont) + comp_args env args' sz + (getmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont) else if nargs < 4 then - comp_args env (met::obj::args) sz - (Kgetmethod :: Kapply nargs :: cont) + comp_args env args' sz + (getmethod :: 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) + comp_args env args' (sz + 3) + (getmethod :: Kapply nargs :: cont1) end | Lfunction(kind, params, body) -> (* assume kind = Curried *) let lbl = new_label() in @@ -467,7 +474,7 @@ let rec comp_expr env exp sz cont = | [] -> 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 :: + Kccall("caml_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 :: @@ -483,7 +490,7 @@ let rec comp_expr env exp sz cont = | [] -> 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) :: + (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) :: comp_rec new_env sz (i-1) rem) | (id, exp, RHS_nonrec) :: rem -> comp_rec new_env sz (i-1) rem @@ -554,7 +561,7 @@ let rec comp_expr env exp sz cont = then Kmakeblock(0, 0) :: cont else comp_args env args sz (Kmakeblock(List.length args, 0) :: - Kccall("make_array", 1) :: cont) + Kccall("caml_make_array", 1) :: cont) end (* Integer first for enabling futher optimization (cf. emitcode.ml) *) | Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) -> @@ -637,7 +644,7 @@ let rec comp_expr env exp sz cont = let (branch, cont1) = make_branch cont in let c = ref (discard_dead_code cont1) in (* Build indirection vectors *) - let store = mk_store (=) in + let store = mk_store Lambda.same in let act_consts = Array.create sw.sw_numconsts 0 and act_blocks = Array.create sw.sw_numblocks 0 in begin match sw.sw_failaction with (* default is index 0 *) @@ -714,7 +721,7 @@ let rec comp_expr env exp sz cont = let info = match lam with Lapply(_, args) -> Event_return (List.length args) - | Lsend(_, _, args) -> Event_return (List.length args + 1) + | Lsend(_, _, _, args) -> Event_return (List.length args + 1) | _ -> Event_other in let ev = event (Event_after ty) info in @@ -779,7 +786,7 @@ let comp_block env exp sz cont = (* +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) :: + Kccall("caml_ensure_stack_capacity", 1) :: code else code diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 830b2b2b..7eb0809e 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytelink.ml,v 1.80 2002/11/17 16:42:10 xleroy Exp $ *) +(* $Id: bytelink.ml,v 1.83.4.1 2004/07/02 09:10:50 xleroy Exp $ *) (* Link a set of .cmo files and produce a bytecode executable. *) @@ -264,13 +264,10 @@ let make_absolute 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 + Misc.remove_file exec_name; (* avoid permission problems, cf PR#1911 *) + let outchan = + open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] + 0o777 exec_name in try if standalone then begin (* Copy the header *) @@ -384,6 +381,13 @@ let link_bytecode_as_c tolink outfile = let outchan = open_out outfile in try (* The bytecode *) + output_string outchan "#include \n"; + output_string outchan "\ +CAMLextern void caml_startup_code( + code_t code, asize_t code_size, + char *data, asize_t data_size, + char *section_table, asize_t section_table_size, + char **argv);\n"; output_string outchan "static int caml_code[] = {\n"; Symtable.init(); Consistbl.clear crc_interfaces; @@ -396,15 +400,26 @@ let link_bytecode_as_c tolink outfile = 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"; + output_string outchan "\n};\n\n"; + (* The sections *) + let sections = + [ "SYMB", Symtable.data_global_map(); + "PRIM", Obj.repr(Symtable.data_primitive_names()); + "CRCS", Obj.repr(extract_crc_interfaces()) ] in + output_string outchan "static char caml_sections[] = {\n"; + output_data_string outchan + (Marshal.to_string sections []); + output_string 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; +void caml_startup(char ** argv) { - caml_startup_code(caml_code, sizeof(caml_code), caml_data, argv); + caml_startup_code(caml_code, sizeof(caml_code), + caml_data, sizeof(caml_data), + caml_sections, sizeof(caml_sections), + argv); }\n"; close_out outchan with x -> @@ -455,35 +470,6 @@ let build_custom_runtime prim_name exec_name = 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 = diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 33841c5b..853d0db5 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytepackager.ml,v 1.3 2003/03/10 16:56:22 xleroy Exp $ *) +(* $Id: bytepackager.ml,v 1.4 2004/04/09 13:32:27 xleroy Exp $ *) (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) @@ -72,24 +72,37 @@ let relocate_debug base ev = (* 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 +type pack_member_kind = PM_intf | PM_impl of compilation_unit + +type pack_member = + { pm_file: string; + pm_name: string; + pm_kind: pack_member_kind } + +let read_member_info file = + let name = + String.capitalize(Filename.basename(chop_extension_if_any file)) in + let kind = + if Filename.check_suffix file ".cmo" then begin + let ic = open_in_bin file 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 file)); + 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 <> name + then raise(Error(Illegal_renaming(file, compunit.cu_name))); + close_in ic; + PM_impl compunit + with x -> + close_in ic; + raise x + end else + PM_intf in + { pm_file = file; pm_name = name; pm_kind = kind } (* Read the bytecode from a .cmo file. Write bytecode to channel [oc]. @@ -97,7 +110,7 @@ let read_unit_info objfile = Accumulate relocs, debug info, etc. Return size of bytecode. *) -let rename_append_bytecode oc mapping defined ofs (objfile, compunit) = +let rename_append_bytecode oc mapping defined ofs objfile compunit = let ic = open_in_bin objfile in try Bytelink.check_consistency objfile compunit; @@ -118,23 +131,37 @@ let rename_append_bytecode oc mapping defined ofs (objfile, compunit) = close_in ic; raise x -(* Same, for a list of .cmo files. Return total size of bytecode. *) +(* Same, for a list of .cmo and .cmi 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 + | m :: rem -> + match m.pm_kind with + | PM_intf -> + rename_append_bytecode_list oc mapping defined ofs rem + | PM_impl compunit -> + let size = + rename_append_bytecode oc mapping defined ofs + m.pm_file compunit in + rename_append_bytecode_list + oc mapping (Ident.create_persistent m.pm_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 build_global_target oc target_name members mapping pos coercion = + let components = + List.map2 + (fun m (id1, id2) -> + match m.pm_kind with + | PM_intf -> None + | PM_impl _ -> Some id2) + members mapping in let lam = - Translmod.transl_package (List.map snd mapping) - (Ident.create_persistent target_name) coercion in + Translmod.transl_package + components (Ident.create_persistent target_name) coercion in let instrs = Bytegen.compile_implementation target_name lam in let rel = @@ -143,11 +170,11 @@ let build_global_target oc target_name mapping pos coercion = (* 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 package_object_files files targetfile targetname coercion = + let members = + map_left_right read_member_info files in let unit_names = - List.map (fun (_, cu) -> cu.cu_name) units in + List.map (fun m -> m.pm_name) members in let mapping = List.map (fun name -> @@ -160,8 +187,8 @@ let package_object_files objfiles targetfile targetname coercion = 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 ofs = rename_append_bytecode_list oc mapping [] 0 members in + build_global_target oc targetname members mapping ofs coercion; let pos_debug = pos_out oc in if !Clflags.debug && !events <> [] then output_value oc (List.rev !events); @@ -191,7 +218,7 @@ let package_object_files objfiles targetfile targetname coercion = (* The entry point *) let package_files files targetfile = - let objfiles = + let files = List.map (fun f -> try find_in_path !Config.load_path f @@ -201,8 +228,8 @@ let package_files files targetfile = 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 + let coercion = Typemod.package_units files targetcmi targetname in + package_object_files files targetfile targetname coercion with x -> remove_file targetfile; raise x diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml index 97fbf7a2..1200a436 100644 --- a/bytecomp/bytesections.ml +++ b/bytecomp/bytesections.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytesections.ml,v 1.2 2001/08/28 14:47:06 xleroy Exp $ *) +(* $Id: bytesections.ml,v 1.3 2004/02/22 15:07:50 xleroy Exp $ *) (* Handling of sections in bytecode executable files *) @@ -80,12 +80,18 @@ let seek_section ic name = (* Return the contents of a section, as a string *) -let read_section ic name = +let read_section_string ic name = let len = seek_section ic name in let res = String.create len in really_input ic res 0 len; res +(* Return the contents of a section, as marshalled data *) + +let read_section_struct ic name = + ignore (seek_section ic name); + input_value ic + (* Return the position of the beginning of the first section *) let pos_first_section ic = diff --git a/bytecomp/bytesections.mli b/bytecomp/bytesections.mli index e7418b64..7d3d3155 100644 --- a/bytecomp/bytesections.mli +++ b/bytecomp/bytesections.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytesections.mli,v 1.2 2001/08/28 14:47:06 xleroy Exp $ *) +(* $Id: bytesections.mli,v 1.3 2004/02/22 15:07:50 xleroy Exp $ *) (* Handling of sections in bytecode executable files *) @@ -44,8 +44,11 @@ val seek_section: in_channel -> string -> int and return the length of that section. Raise Not_found if no such section exists. *) -val read_section: in_channel -> string -> string +val read_section_string: in_channel -> string -> string (* Return the contents of a section, as a string *) +val read_section_struct: in_channel -> string -> 'a + (* Return the contents of a section, as marshalled data *) + 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 index ce66421a..93f0b0ae 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -10,20 +10,21 @@ (* *) (***********************************************************************) -(* $Id: dll.ml,v 1.10 2002/07/02 16:13:12 weis Exp $ *) +(* $Id: dll.ml,v 1.12 2004/01/16 15:24:02 doligez 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" +external dll_open: string -> dll_handle = "caml_dynlink_open_lib" +external dll_close: dll_handle -> unit = "caml_dynlink_close_lib" +external dll_sym: dll_handle -> string -> dll_address + = "caml_dynlink_lookup_symbol" (* returned dll_address may be Val_unit *) -external add_primitive: dll_address -> int = "dynlink_add_primitive" +external add_primitive: dll_address -> int = "caml_dynlink_add_primitive" external get_current_dlls: unit -> dll_handle array - = "dynlink_get_current_libs" + = "caml_dynlink_get_current_libs" (* Current search path for DLLs *) let search_path = ref ([] : string list) @@ -138,7 +139,6 @@ let ld_library_path_contents () = match Sys.os_type with | "Unix" | "Cygwin" -> ':' | "Win32" -> ';' - | "MacOS" -> ',' | _ -> assert false in try split (Sys.getenv "CAML_LD_LIBRARY_PATH") path_separator diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 05f15285..8e60088d 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emitcode.ml,v 1.31 2003/03/06 15:59:54 xleroy Exp $ *) +(* $Id: emitcode.ml,v 1.32 2004/05/26 11:10:50 garrigue Exp $ *) (* Generation of bytecode + relocation information *) @@ -293,6 +293,8 @@ let emit_instr = function | Kisint -> out opISINT | Kisout -> out opULTINT | Kgetmethod -> out opGETMETHOD + | Kgetpubmet tag -> out opGETPUBMET; out_int tag; out_int 0 + | Kgetdynmet -> out opGETDYNMET | Kevent ev -> record_event ev | Kstop -> out opSTOP diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index 02c9747f..f84ac26a 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: instruct.ml,v 1.20 2002/11/02 22:36:41 doligez Exp $ *) +(* $Id: instruct.ml,v 1.21 2004/05/26 11:10:50 garrigue Exp $ *) open Lambda @@ -97,6 +97,8 @@ type instruction = | Kisint | Kisout | Kgetmethod + | Kgetpubmet of int + | Kgetdynmet | Kevent of debug_event | Kstop diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index 01669530..99f56c72 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: instruct.mli,v 1.19 2002/11/02 22:36:41 doligez Exp $ *) +(* $Id: instruct.mli,v 1.20 2004/05/26 11:10:50 garrigue Exp $ *) (* The type of the instructions of the abstract machine *) @@ -116,6 +116,8 @@ type instruction = | Kisint | Kisout | Kgetmethod + | Kgetpubmet of int + | Kgetdynmet | Kevent of debug_event | Kstop diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index fbb7a209..82cdbf94 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lambda.ml,v 1.39 2002/11/01 17:06:41 doligez Exp $ *) +(* $Id: lambda.ml,v 1.40.2.1 2004/07/07 16:49:51 xleroy Exp $ *) open Misc open Path @@ -115,6 +115,8 @@ type function_kind = Curried | Tupled type let_kind = Strict | Alias | StrictOpt | Variable +type meth_kind = Self | Public | Cached + type shared_code = (int * int) list type lambda = @@ -134,7 +136,7 @@ type 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 + | Lsend of meth_kind * lambda * lambda * lambda list | Levent of lambda * lambda_event | Lifused of Ident.t * lambda @@ -160,6 +162,64 @@ let const_unit = Const_pointer 0 let lambda_unit = Lconst const_unit +let rec same l1 l2 = + match (l1, l2) with + | Lvar v1, Lvar v2 -> + Ident.same v1 v2 + | Lconst c1, Lconst c2 -> + c1 = c2 + | Lapply(a1, bl1), Lapply(a2, bl2) -> + same a1 a2 && samelist same bl1 bl2 + | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> + k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 + | Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) -> + k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2 + | Lletrec (bl1, a1), Lletrec (bl2, a2) -> + samelist samebinding bl1 bl2 && same a1 a2 + | Lprim(p1, al1), Lprim(p2, al2) -> + p1 = p2 && samelist same al1 al2 + | Lswitch(a1, s1), Lswitch(a2, s2) -> + same a1 a2 && sameswitch s1 s2 + | Lstaticraise(n1, al1), Lstaticraise(n2, al2) -> + n1 = n2 && samelist same al1 al2 + | Lstaticcatch(a1, (n1, idl1), b1), Lstaticcatch(a2, (n2, idl2), b2) -> + same a1 a2 && n1 = n2 && samelist Ident.same idl1 idl2 && same b1 b2 + | Ltrywith(a1, id1, b1), Ltrywith(a2, id2, b2) -> + same a1 a2 && Ident.same id1 id2 && same b1 b2 + | Lifthenelse(a1, b1, c1), Lifthenelse(a2, b2, c2) -> + same a1 a2 && same b1 b2 && same c1 c2 + | Lsequence(a1, b1), Lsequence(a2, b2) -> + same a1 a2 && same b1 b2 + | Lwhile(a1, b1), Lwhile(a2, b2) -> + same a1 a2 && same b1 b2 + | Lfor(id1, a1, b1, df1, c1), Lfor(id2, a2, b2, df2, c2) -> + Ident.same id1 id2 && same a1 a2 && + same b1 b2 && df1 = df2 && same c1 c2 + | Lassign(id1, a1), Lassign(id2, a2) -> + Ident.same id1 id2 && same a1 a2 + | Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) -> + k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2 + | Levent(a1, ev1), Levent(a2, ev2) -> + same a1 a2 && ev1.lev_pos = ev2.lev_pos + | Lifused(id1, a1), Lifused(id2, a2) -> + Ident.same id1 id2 && same a1 a2 + | _, _ -> + false + +and samebinding (id1, c1) (id2, c2) = + Ident.same id1 id2 && same c1 c2 + +and sameswitch sw1 sw2 = + let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in + sw1.sw_numconsts = sw2.sw_numconsts && + sw1.sw_numblocks = sw2.sw_numblocks && + samelist samecase sw1.sw_consts sw2.sw_consts && + samelist samecase sw1.sw_blocks sw2.sw_blocks && + (match (sw1.sw_failaction, sw2.sw_failaction) with + | (None, None) -> true + | (Some a1, Some a2) -> same a1 a2 + | _ -> false) + let name_lambda arg fn = match arg with Lvar id -> fn id @@ -225,7 +285,7 @@ let free_variables l = 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) -> + | Lsend (k, met, obj, args) -> List.iter freevars (met::obj::args) | Levent (lam, evt) -> freevars lam @@ -309,7 +369,8 @@ let subst_lambda s lam = | 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) + | Lsend (k, met, obj, args) -> + Lsend (k, 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) diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 376d1900..03421407 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lambda.mli,v 1.37 2002/11/01 17:06:41 doligez Exp $ *) +(* $Id: lambda.mli,v 1.38.2.1 2004/07/07 16:49:53 xleroy Exp $ *) (* The "lambda" intermediate code *) @@ -124,6 +124,8 @@ type let_kind = Strict | Alias | StrictOpt | Variable we can discard e if x does not appear in e' Variable: the variable x is assigned later in e' *) +type meth_kind = Self | Public | Cached + type shared_code = (int * int) list (* stack size -> code label *) type lambda = @@ -143,7 +145,7 @@ type 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 + | Lsend of meth_kind * lambda * lambda * lambda list | Levent of lambda * lambda_event | Lifused of Ident.t * lambda @@ -164,6 +166,7 @@ and lambda_event_kind = | Lev_after of Types.type_expr | Lev_function +val same: lambda -> lambda -> bool val const_unit: structured_constant val lambda_unit: lambda val name_lambda: lambda -> (Ident.t -> lambda) -> lambda diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index c04da97c..b6cd882b 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: matching.ml,v 1.58 2003/07/18 13:37:36 maranget Exp $ *) +(* $Id: matching.ml,v 1.60 2004/04/29 12:38:11 maranget Exp $ *) (* Compilation of pattern matching *) @@ -376,11 +376,11 @@ let pretty_cases cases = 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 @@ -777,7 +777,7 @@ let rebuild_nexts arg nexts k = (* Split a matching. Splitting is first directed by or-patterns, then by - must test (e.g. constructors)/variable transitions. + tests (e.g. constructors)/variable transitions. The approach is greedy, every split function attempt to raise rows as much as possible in the top matrix, @@ -1456,7 +1456,7 @@ let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg]) let prim_string_notequal = - Pccall{prim_name = "string_notequal"; + Pccall{prim_name = "caml_string_notequal"; prim_arity = 2; prim_alloc = false; prim_native_name = ""; prim_native_float = false} @@ -1777,13 +1777,21 @@ let mk_res get_key env last_choice idef cant_fail ctx = fail, klist, jumps -(* Aucune optimisation, reflechir apres la release *) +(* + Following two ``failaction'' function compute n, the trap handler + to jump to in case of failure of elementary tests +*) + 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 + | _ -> + (* Act as Total, this means + If no appropriate default matrix exists, + then this switch cannot fail *) + None, [], jumps_empty end | Total -> None, [], jumps_empty @@ -2283,7 +2291,7 @@ 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 ; + pretty_precompiled x ; prerr_endline "CTX" ; pretty_ctx ctx ; let (_, jumps) as r = do_compile_matching repr partial ctx arg x in diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 17ee17ac..96a26a88 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: matching.mli,v 1.11 2001/02/19 20:27:35 maranget Exp $ *) +(* $Id: matching.mli,v 1.12 2004/05/26 11:10:50 garrigue Exp $ *) (* Compilation of pattern-matching *) @@ -35,3 +35,7 @@ val for_tupled_function: exception Cannot_flatten val flatten_pattern: int -> pattern -> pattern list + +val make_test_sequence: + lambda option -> primitive -> primitive -> lambda -> + (Asttypes.constant * lambda) list -> lambda diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml index 50f5aff1..08cf707b 100644 --- a/bytecomp/meta.ml +++ b/bytecomp/meta.ml @@ -10,14 +10,17 @@ (* *) (***********************************************************************) -(* $Id: meta.ml,v 1.9 2001/08/28 14:47:07 xleroy Exp $ *) +(* $Id: meta.ml,v 1.13 2004/04/16 13:46:20 starynke 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" +external global_data : unit -> Obj.t array = "caml_get_global_data" +external realloc_global_data : int -> unit = "caml_realloc_global" +external static_alloc : int -> string = "caml_static_alloc" +external static_free : string -> unit = "caml_static_free" +external static_resize : string -> int -> string = "caml_static_resize" +external static_release_bytecode : string -> int -> unit = "caml_static_release_bytecode" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "reify_bytecode" +external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t - = "invoke_traced_function" + = "caml_invoke_traced_function" +external get_section_table : unit -> (string * Obj.t) list + = "caml_get_section_table" diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli index b86dee4f..0cbe85ab 100644 --- a/bytecomp/meta.mli +++ b/bytecomp/meta.mli @@ -10,16 +10,19 @@ (* *) (***********************************************************************) -(* $Id: meta.mli,v 1.9 2001/08/28 14:47:07 xleroy Exp $ *) +(* $Id: meta.mli,v 1.13 2004/04/16 13:46:27 starynke 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" +external global_data : unit -> Obj.t array = "caml_get_global_data" +external realloc_global_data : int -> unit = "caml_realloc_global" +external static_alloc : int -> string = "caml_static_alloc" +external static_free : string -> unit = "caml_static_free" +external static_release_bytecode : string -> int -> unit = "caml_static_release_bytecode" +external static_resize : string -> int -> string = "caml_static_resize" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "reify_bytecode" +external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t - = "invoke_traced_function" + = "caml_invoke_traced_function" +external get_section_table : unit -> (string * Obj.t) list + = "caml_get_section_table" diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml index 6594eb26..4801db6b 100644 --- a/bytecomp/printinstr.ml +++ b/bytecomp/printinstr.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printinstr.ml,v 1.21 2002/11/02 22:36:42 doligez Exp $ *) +(* $Id: printinstr.ml,v 1.22 2004/05/26 11:10:50 garrigue Exp $ *) (* Pretty-print lists of instructions *) @@ -96,6 +96,8 @@ let instruction ppf = function | Kisint -> fprintf ppf "\tisint" | Kisout -> fprintf ppf "\tisout" | Kgetmethod -> fprintf ppf "\tgetmethod" + | Kgetpubmet n -> fprintf ppf "\tgetpubmet %i" n + | Kgetdynmet -> fprintf ppf "\tgetdynmet" | Kstop -> fprintf ppf "\tstop" | Kevent ev -> fprintf ppf "\tevent \"%s\" %i" ev.ev_char.Lexing.pos_fname ev.ev_char.Lexing.pos_cnum diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 63658dc2..4b97a824 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printlambda.ml,v 1.48 2003/04/25 12:27:30 xleroy Exp $ *) +(* $Id: printlambda.ml,v 1.49 2004/05/26 11:10:50 garrigue Exp $ *) open Format open Asttypes @@ -274,10 +274,12 @@ let rec lam ppf = function lam hi lam body | Lassign(id, expr) -> fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - | Lsend (met, obj, largs) -> + | Lsend (k, 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 + let kind = + if k = Self then "self" else if k = Cached then "cache" else "" in + fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs | Levent(expr, ev) -> let kind = match ev.lev_kind with diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index 7bef70d6..4faa9155 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: simplif.ml,v 1.22 2001/04/23 12:46:21 maranget Exp $ *) +(* $Id: simplif.ml,v 1.23 2004/05/26 11:10:50 garrigue Exp $ *) (* Elimination of useless Llet(Alias) bindings. Also transform let-bound references into variables. *) @@ -75,8 +75,8 @@ let rec eliminate_ref id = function 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, + | Lsend(k, m, o, el) -> + Lsend(k, eliminate_ref id m, eliminate_ref id o, List.map (eliminate_ref id) el) | Levent(l, ev) -> Levent(eliminate_ref id l, ev) @@ -144,7 +144,7 @@ let simplify_exits lam = (* 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) + | Lsend(k, m, o, ll) -> List.iter count (m::o::ll) | Levent(l, _) -> count l | Lifused(v, l) -> count l @@ -250,7 +250,7 @@ let simplify_exits lam = | 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) + | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll) | Levent(l, ev) -> Levent(simplif l, ev) | Lifused(v, l) -> Lifused (v,simplif l) in @@ -313,7 +313,7 @@ let simplify_lets lam = (* 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) + | 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 @@ -402,7 +402,7 @@ let simplify_lets lam = | 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) + | Lsend(k, m, o, ll) -> Lsend(k, 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 diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 54f03190..6e8966f5 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: symtable.ml,v 1.35 2003/05/26 13:46:06 xleroy Exp $ *) +(* $Id: symtable.ml,v 1.37 2004/02/22 15:07:50 xleroy Exp $ *) (* To assign numbers to globals and primitives *) @@ -99,11 +99,16 @@ let all_primitives () = Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl; prim -let output_primitive_names outchan = +let data_primitive_names () = let prim = all_primitives() in + let b = Buffer.create 512 in for i = 0 to Array.length prim - 1 do - output_string outchan prim.(i); output_char outchan '\000' - done + Buffer.add_string b prim.(i); Buffer.add_char b '\000' + done; + Buffer.contents b + +let output_primitive_names outchan = + output_string outchan (data_primitive_names()) open Printf @@ -117,12 +122,12 @@ let output_primitive_table outchan = fprintf outchan "extern long %s();\n" prim.(i) done; fprintf outchan "typedef long (*primitive)();\n"; - fprintf outchan "primitive builtin_cprim[] = {\n"; + fprintf outchan "primitive caml_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"; + fprintf outchan "char * caml_names_of_builtin_cprim[] = {\n"; for i = 0 to Array.length prim - 1 do fprintf outchan " \"%s\",\n" prim.(i) done; @@ -232,6 +237,9 @@ let initial_global_table () = let output_global_map oc = output_value oc !global_table +let data_global_map () = + Obj.repr !global_table + (* Functions for toplevel use *) (* Update the in-core table of globals *) @@ -245,39 +253,59 @@ let update_global_table () = !literal_table; literal_table := [] +(* Recover data for toplevel initialization. Data can come either from + executable file (normal case) or from linked-in data (-output-obj). *) + +type section_reader = { + read_string: string -> string; + read_struct: string -> Obj.t; + close_reader: unit -> unit +} + +let read_sections () = + try + let sections = Meta.get_section_table () in + { read_string = + (fun name -> (Obj.magic(List.assoc name sections) : string)); + read_struct = + (fun name -> List.assoc name sections); + close_reader = + (fun () -> ()) } + with Not_found -> + let ic = open_in_bin Sys.executable_name in + Bytesections.read_toc ic; + { read_string = Bytesections.read_section_string ic; + read_struct = Bytesections.read_section_struct ic; + close_reader = fun () -> close_in ic } + (* 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 + try + let sect = read_sections () in + (* Locations of globals *) + global_table := (Obj.magic (sect.read_struct "SYMB") : Ident.t numtable); + (* Primitives *) + let prims = sect.read_string "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 + done; + (* DLL initialization *) + let dllpath = try sect.read_string "DLPT" with Not_found -> "" in + Dll.init_toplevel dllpath; + (* Recover CRC infos for interfaces *) + let crcintfs = + try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t) list) + with Not_found -> [] in + (* Done *) + sect.close_reader(); + crcintfs 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 *) diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index 3b21587c..674b843a 100644 --- a/bytecomp/symtable.mli +++ b/bytecomp/symtable.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: symtable.mli,v 1.13 2003/05/26 13:46:06 xleroy Exp $ *) +(* $Id: symtable.mli,v 1.14 2004/02/22 15:07:50 xleroy Exp $ *) (* Assign locations and numbers to globals and primitives *) @@ -25,6 +25,8 @@ 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 +val data_global_map: unit -> Obj.t +val data_primitive_names: unit -> string (* Functions for the toplevel *) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index e525937f..a192262d 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translclass.ml,v 1.24 2003/06/19 15:53:48 xleroy Exp $ *) +(* $Id: translclass.ml,v 1.32 2004/05/26 11:10:50 garrigue Exp $ *) open Misc open Asttypes @@ -22,11 +22,12 @@ open Translcore (* XXX Rajouter des evenements... *) -type error = Illegal_class_expr +type error = Illegal_class_expr | Tags of label * label exception Error of Location.t * error let lfunction params body = + if params = [] then body else match body with Lfunction (Curried, params', body') -> Lfunction (Curried, params @ params', body') @@ -43,13 +44,14 @@ let 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 lfield v i = Lprim(Pfield i, [Lvar v]) + +let transl_label l = share (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)) + if lst = [] then Lconst (Const_pointer 0) else + share (Const_block + (0, List.map (fun lab -> Const_base (Const_string lab)) lst)) let set_inst_var obj id expr = let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in @@ -65,15 +67,26 @@ let copy_inst_var obj id expr templ offset = [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_val tbl create name = + Lapply (oo_prim (if create then "new_variable" else "get_variable"), + [Lvar tbl; transl_label name]) -let transl_vals tbl create vals rem = +let transl_vals tbl create sure vals rem = + if create && sure && List.length vals > 1 then + let (_,id0) = List.hd vals in + let call = + Lapply(oo_prim "new_variables", + [Lvar tbl; transl_meth_list (List.map fst vals)]) in + let i = ref (List.length vals) in + Llet(Strict, id0, call, + List.fold_right + (fun (name,id) rem -> + decr i; Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem)) + (List.tl vals) rem) + else List.fold_right - (fun (name, id) rem -> transl_val tbl create name id rem) + (fun (name, id) rem -> + Llet(StrictOpt, id, transl_val tbl create name, rem)) vals rem let transl_super tbl meths inh_methods rem = @@ -90,40 +103,52 @@ let transl_super tbl meths inh_methods rem = let create_object cl obj init = let obj' = Ident.create "self" in - let (inh_init, obj_init) = init obj' in + let (inh_init, obj_init, has_init) = init obj' in if obj_init = lambda_unit then - (inh_init, - Lapply (oo_prim "create_object_and_run_initializers", - [Lvar obj; Lvar cl])) + (inh_init, + Lapply (oo_prim (if has_init then "create_object_and_run_initializers" + else"create_object_opt"), + [obj; Lvar cl])) else begin (inh_init, Llet(Strict, obj', - Lapply (oo_prim "create_object_opt", [Lvar obj; Lvar cl]), + Lapply (oo_prim "create_object_opt", [obj; Lvar cl]), Lsequence(obj_init, - Lapply (oo_prim "run_initializers_opt", - [Lvar obj; Lvar obj'; Lvar cl])))) + if not has_init then Lvar obj' else + Lapply (oo_prim "run_initializers_opt", + [obj; Lvar obj'; Lvar cl])))) end -let rec build_object_init cl_table obj params inh_init cl = +let rec build_object_init cl_table obj params inh_init obj_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])) + let envs, inh_init = inh_init in + let env = + match envs with None -> [] + | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])] + in + ((envs, (obj_init, path)::inh_init), + Lapply(Lvar obj_init, env @ [obj])) | Tclass_structure str -> create_object cl_table obj (fun obj -> - let (inh_init, obj_init) = + let (inh_init, obj_init, has_init) = List.fold_right - (fun field (inh_init, obj_init) -> + (fun field (inh_init, obj_init, has_init) -> match field with Cf_inher (cl, _, _) -> let (inh_init, obj_init') = - build_object_init cl_table obj [] inh_init cl + build_object_init cl_table (Lvar obj) [] inh_init + (fun _ -> lambda_unit) cl in - (inh_init, lsequence obj_init' obj_init) + (inh_init, lsequence obj_init' obj_init, true) | Cf_val (_, id, exp) -> - (inh_init, lsequence (set_inst_var obj id exp) obj_init) - | Cf_meth _ | Cf_init _ -> - (inh_init, obj_init) + (inh_init, lsequence (set_inst_var obj id exp) obj_init, + has_init) + | Cf_meth _ -> + (inh_init, obj_init, has_init) + | Cf_init _ -> + (inh_init, obj_init, true) | Cf_let (rec_flag, defs, vals) -> (inh_init, Translcore.transl_let rec_flag defs @@ -131,18 +156,20 @@ let rec build_object_init cl_table obj params inh_init cl = (fun (id, expr) rem -> lsequence (Lifused(id, set_inst_var obj id expr)) rem) - vals obj_init))) + vals obj_init), + has_init)) str.cl_field - (inh_init, lambda_unit) + (inh_init, obj_init obj, false) in (inh_init, List.fold_right (fun (id, expr) rem -> lsequence (Lifused (id, set_inst_var obj id expr)) rem) - params obj_init)) + params obj_init, + has_init)) | Tclass_fun (pat, vals, cl, partial) -> let (inh_init, obj_init) = - build_object_init cl_table obj (vals @ params) inh_init cl + build_object_init cl_table obj (vals @ params) inh_init obj_init cl in (inh_init, let build params rem = @@ -157,173 +184,599 @@ let rec build_object_init cl_table obj params inh_init cl = end) | Tclass_apply (cl, oexprs) -> let (inh_init, obj_init) = - build_object_init cl_table obj params inh_init cl + build_object_init cl_table obj params inh_init obj_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 + build_object_init cl_table obj (vals @ params) inh_init obj_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 + build_object_init cl_table obj params inh_init obj_init cl -let rec build_object_init_0 cl_table params cl = +let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = 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) + build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids | _ -> - 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 self = Ident.create "self" in + let env = Ident.create "env" in + let obj = if ids = [] then lambda_unit else Lvar self in + let envs = if top then None else Some env in + let ((_,inh_init), obj_init) = + build_object_init cl_table obj params (envs,[]) (copy_env env) cl in + let obj_init = + if ids = [] then obj_init else lfunction [self] obj_init in + (inh_init, lfunction [env] (subst_env env inh_init obj_init)) + + +let bind_method tbl lab id cl_init = + 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 bind_methods tbl meths cl_init = + let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in + let len = List.length methl in + if len < 2 then Meths.fold (bind_method tbl) meths cl_init else + let ids = Ident.create "ids" in + let i = ref len in + Llet(StrictOpt, ids, + Lapply (oo_prim "get_method_labels", + [Lvar tbl; transl_meth_list (List.map fst methl)]), + List.fold_right + (fun (lab,id) lam -> + decr i; Llet(StrictOpt, id, Lprim(Pfield !i, [Lvar ids]), lam)) + methl cl_init) -let rec build_class_init cla pub_meths cstr inh_init cl_init cl = +let output_methods tbl vals methods lam = + let lam = + match methods with + [] -> lam + | [lab; code] -> + lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam + | _ -> + lsequence (Lapply(oo_prim "set_methods", + [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)])) + lam + in + transl_vals tbl true true vals lam + +let rec ignore_cstrs cl = + match cl.cl_desc with + Tclass_constraint (cl, _, _, _) -> ignore_cstrs cl + | Tclass_apply (cl, _) -> ignore_cstrs cl + | _ -> cl + +let rec build_class_init cla cstr inh_init cl_init msubst top cl = match cl.cl_desc with Tclass_ident path -> begin match inh_init with - obj_init::inh_init -> + (obj_init, path')::inh_init -> + let lpath = transl_path path in (inh_init, Llet (Strict, obj_init, - Lapply(Lprim(Pfield 1, [transl_path path]), [Lvar cla]), + Lapply(Lprim(Pfield 1, [lpath]), Lvar cla :: + if top then [Lprim(Pfield 3, [lpath])] else []), cl_init)) | _ -> assert false end | Tclass_structure str -> - let (inh_init, cl_init) = + let (inh_init, cl_init, methods, values) = List.fold_right - (fun field (inh_init, cl_init) -> + (fun field (inh_init, cl_init, methods, values) -> 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 + let cl_init = output_methods cla values methods cl_init in + let inh_init, cl_init = + build_class_init cla false inh_init + (transl_vals cla false false vals + (transl_super cla str.cl_meths meths cl_init)) + msubst top cl in + (inh_init, cl_init, [], []) | Cf_val (name, id, exp) -> - (inh_init, transl_val cla true name id cl_init) + (inh_init, cl_init, methods, (name, id)::values) | Cf_meth (name, exp) -> + let met_code = msubst true (transl_exp exp) in let met_code = - if !Clflags.native_code then begin + if !Clflags.native_code && List.length met_code = 1 then (* 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]), + [Llet(Strict, met, List.hd met_code, Lvar met)] + else met_code + in + (inh_init, cl_init, + Lvar (Meths.find name str.cl_meths) :: met_code @ methods, + values) + (* + Lsequence(Lapply (oo_prim ("set_method" ^ builtin), + 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) + (inh_init, cl_init, methods, vals @ values) | Cf_init exp -> (inh_init, Lsequence(Lapply (oo_prim "add_initializer", - [Lvar cla; transl_exp exp]), - cl_init))) + Lvar cla :: msubst false (transl_exp exp)), + cl_init), + methods, values)) str.cl_field - (inh_init, cl_init) + (inh_init, cl_init, [], []) in - (inh_init, bind_methods cla pub_meths str.cl_meths cl_init) + let cl_init = output_methods cla values methods cl_init in + (inh_init, bind_methods cla 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 + build_class_init cla cstr inh_init cl_init msubst top cl in let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + (inh_init, transl_vals cla true false vals cl_init) | Tclass_apply (cl, exprs) -> - build_class_init cla pub_meths cstr inh_init cl_init cl + build_class_init cla cstr inh_init cl_init msubst top 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 + build_class_init cla cstr inh_init cl_init msubst top cl in let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + (inh_init, transl_vals cla true false 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)) + let virt_meths = + List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in + let narrow_args = + [Lvar cla; + transl_meth_list vals; + transl_meth_list virt_meths; + transl_meth_list (Concr.elements concr_meths)] in + let cl = ignore_cstrs cl in + begin match cl.cl_desc, inh_init with + Tclass_ident path, (obj_init, path')::inh_init -> + assert (Path.same path path'); + let lpath = transl_path path in + (inh_init, + Llet (Strict, obj_init, + Lapply(oo_prim "inherits", narrow_args @ + [lpath; Lconst(Const_pointer(if top then 1 else 0))]), + cl_init)) + | _ -> + let core cl_init = + build_class_init cla true inh_init cl_init msubst top cl + in + if cstr then core cl_init else + let (inh_init, cl_init) = + core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init)) + in + (inh_init, + Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init)) + end +let rec build_class_lets cl = + match cl.cl_desc with + Tclass_let (rec_flag, defs, vals, cl) -> + let env, wrap = build_class_lets cl in + (env, fun x -> Translcore.transl_let rec_flag defs (wrap x)) + | _ -> + (cl.cl_env, fun x -> x) (* XXX Il devrait etre peu couteux d'ecrire des classes : class c x y = d e f *) +let rec transl_class_rebind obj_init cl = + match cl.cl_desc with + Tclass_ident path -> + (path, obj_init) + | Tclass_fun (pat, _, cl, partial) -> + let path, obj_init = transl_class_rebind obj_init cl in + 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 + (path, + match obj_init with + Lfunction (Curried, params, rem) -> build params rem + | rem -> build [] rem) + | Tclass_apply (cl, oexprs) -> + let path, obj_init = transl_class_rebind obj_init cl in + (path, transl_apply obj_init oexprs) + | Tclass_let (rec_flag, defs, vals, cl) -> + let path, obj_init = transl_class_rebind obj_init cl in + (path, Translcore.transl_let rec_flag defs obj_init) + | Tclass_structure _ -> raise Exit + | Tclass_constraint (cl', _, _, _) -> + let path, obj_init = transl_class_rebind obj_init cl' in + let rec check_constraint = function + Tcty_constr(path', _, _) when Path.same path path' -> () + | Tcty_fun (_, _, cty) -> check_constraint cty + | _ -> raise Exit + in + check_constraint cl.cl_type; + (path, obj_init) + +let rec transl_class_rebind_0 self obj_init cl = + match cl.cl_desc with + Tclass_let (rec_flag, defs, vals, cl) -> + let path, obj_init = transl_class_rebind_0 self obj_init cl in + (path, Translcore.transl_let rec_flag defs obj_init) + | _ -> + let path, obj_init = transl_class_rebind obj_init cl in + (path, lfunction [self] obj_init) + +let transl_class_rebind ids cl = + try + let obj_init = Ident.create "obj_init" + and self = Ident.create "self" in + let obj_init0 = lapply (Lvar obj_init) [Lvar self] in + let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in + if not (Translcore.check_recursive_lambda ids obj_init') then + raise(Error(cl.cl_loc, Illegal_class_expr)); + let id = (obj_init' = lfunction [self] obj_init0) in + if id then transl_path path else + + let cla = Ident.create "class" + and new_init = Ident.create "new_init" + and arg = Ident.create "arg" + and env_init = Ident.create "env_init" + and table = Ident.create "table" + and envs = Ident.create "envs" in + Llet( + Strict, new_init, lfunction [obj_init] obj_init', + Llet( + Alias, cla, transl_path path, + Lprim(Pmakeblock(0, Immutable), + [Lapply(Lvar new_init, [lfield cla 0]); + lfunction [table] + (Llet(Strict, env_init, + Lapply(lfield cla 1, [Lvar table]), + lfunction [envs] + (Lapply(Lvar new_init, + [Lapply(Lvar env_init, [Lvar envs])])))); + lfield cla 2; + lfield cla 3]))) + with Exit -> + lambda_unit + +(* Rewrite a closure using builtins. Improves native code size. *) + +let rec module_path = function + Lvar id -> + let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z' + | Lprim(Pfield _, [p]) -> module_path p + | Lprim(Pgetglobal _, []) -> true + | _ -> false + +let const_path local = function + Lvar id -> not (List.mem id local) + | Lconst _ -> true + | Lfunction (Curried, _, body) -> + let fv = free_variables body in + List.for_all (fun x -> not (IdentSet.mem x fv)) local + | p -> module_path p + +let rec builtin_meths self env env2 body = + let const_path = const_path (env::self) in + let conv = function + (* Lvar s when List.mem s self -> "_self", [] *) + | p when const_path p -> "const", [p] + | Lprim(Parrayrefu _, [Lvar s; Lvar n]) when List.mem s self -> + "var", [Lvar n] + | Lprim(Pfield n, [Lvar e]) when Ident.same e env -> + "env", [Lvar env2; Lconst(Const_pointer n)] + | Lsend(Self, met, Lvar s, []) when List.mem s self -> + "meth", [met] + | _ -> raise Not_found + in + match body with + | Llet(Alias, s', Lvar s, body) when List.mem s self -> + builtin_meths self env env2 body + | Lapply(f, [arg]) when const_path f -> + let s, args = conv arg in ("app_"^s, f :: args) + | Lapply(f, [arg; p]) when const_path f && const_path p -> + let s, args = conv arg in + ("app_"^s^"_const", f :: args @ [p]) + | Lapply(f, [p; arg]) when const_path f && const_path p -> + let s, args = conv arg in + ("app_const_"^s, f :: p :: args) + | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self -> + let s, args = conv arg in + ("meth_app_"^s, Lvar n :: args) + | Lsend(Self, met, Lvar s, []) when List.mem s self -> + ("get_meth", [met]) + | Lsend(Public, met, arg, []) -> + let s, args = conv arg in + ("send_"^s, met :: args) + | Lsend(Cached, met, arg, [_;_]) -> + let s, args = conv arg in + ("send_"^s, met :: args) + | Lfunction (Curried, [x], body) -> + let rec enter self = function + | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x']) + when Ident.same x x' && List.mem s self -> + ("set_var", [Lvar n]) + | Llet(Alias, s', Lvar s, body) when List.mem s self -> + enter (s'::self) body + | _ -> raise Not_found + in enter self body + | Lfunction _ -> raise Not_found + | _ -> + let s, args = conv body in ("get_"^s, args) + +module M = struct + open CamlinternalOO + let builtin_meths arr self env env2 body = + let builtin, args = builtin_meths self env env2 body in + if not arr then [Lapply(oo_prim builtin, args)] else + let tag = match builtin with + "get_const" -> GetConst + | "get_var" -> GetVar + | "get_env" -> GetEnv + | "get_meth" -> GetMeth + | "set_var" -> SetVar + | "app_const" -> AppConst + | "app_var" -> AppVar + | "app_env" -> AppEnv + | "app_meth" -> AppMeth + | "app_const_const" -> AppConstConst + | "app_const_var" -> AppConstVar + | "app_const_env" -> AppConstEnv + | "app_const_meth" -> AppConstMeth + | "app_var_const" -> AppVarConst + | "app_env_const" -> AppEnvConst + | "app_meth_const" -> AppMethConst + | "meth_app_const" -> MethAppConst + | "meth_app_var" -> MethAppVar + | "meth_app_env" -> MethAppEnv + | "meth_app_meth" -> MethAppMeth + | "send_const" -> SendConst + | "send_var" -> SendVar + | "send_env" -> SendEnv + | "send_meth" -> SendMeth + | _ -> assert false + in Lconst(Const_pointer(Obj.magic tag)) :: args +end +open M + + (* - XXX - Exploiter le fait que les methodes sont definies dans l'ordre pour - l'initialisation des classes (et les variables liees par un - let ???) ? + Traduction d'une classe. + Plusieurs cas: + * reapplication d'une classe connue -> transl_class_rebind + * classe sans dependances locales -> traduction directe + * avec dependances locale -> creation d'un arbre de stubs, + avec un noeud pour chaque classe locale heritee + Une classe est un 4-uplet: + (obj_init, class_init, env_init, env) + obj_init: fonction de creation d'objet (unit -> obj) + class_init: fonction d'heritage (table -> env_init) + (une seule par code source) + env_init: parametrage par l'environnement local (env -> params -> obj_init) + (une par combinaison de class_init herites) + env: environnement local + Si ids=0 (objet immediat), alors on ne conserve que env_init. *) + let transl_class ids cl_id arity pub_meths cl = + (* First check if it is not only a rebind *) + let rebind = transl_class_rebind ids cl in + if rebind <> lambda_unit then rebind else + + (* Prepare for heavy environment handling *) + let tables = Ident.create (Ident.name cl_id ^ "_tables") in + let (top_env, req) = oo_add_class tables in + let top = not req in + let cl_env, llets = build_class_lets cl in + let new_ids = if top then [] else Env.diff top_env cl_env in + let env2 = Ident.create "env" in + let subst env lam i0 new_ids' = + let fv = free_variables lam in + let fv = List.fold_right IdentSet.remove !new_ids' fv in + let fv = + IdentSet.filter (fun id -> List.mem id new_ids) fv in + new_ids' := !new_ids' @ IdentSet.elements fv; + let i = ref (i0-1) in + List.fold_left + (fun subst id -> + incr i; Ident.add id (lfield env !i) subst) + Ident.empty !new_ids' + in + let new_ids_meths = ref [] in + let msubst arr = function + Lfunction (Curried, self :: args, body) -> + let env = Ident.create "env" in + let body' = + if new_ids = [] then body else + subst_lambda (subst env body 0 new_ids_meths) body in + begin try + (* Doesn't seem to improve size for bytecode *) + (* if not !Clflags.native_code then raise Not_found; *) + builtin_meths arr [self] env env2 (lfunction args body') + with Not_found -> + [lfunction (self :: args) + (if not (IdentSet.mem env (free_variables body')) then body' else + Llet(Alias, env, + Lprim(Parrayrefu Paddrarray, + [Lvar self; Lvar env2]), body'))] + end + | _ -> assert false + in + let new_ids_init = ref [] in + let env1 = Ident.create "env" and env1' = Ident.create "env'" in + let copy_env envs self = + if top then lambda_unit else + Lifused(env2, Lprim(Parraysetu Paddrarray, + [Lvar self; Lvar env2; Lvar env1'])) + and subst_env envs l lam = + if top then lam else + (* must be called only once! *) + let lam = subst_lambda (subst env1 lam 1 new_ids_init) lam in + Llet(Alias, env1, (if l = [] then Lvar envs else lfield envs 0), + Llet(Alias, env1', + (if !new_ids_init = [] then Lvar env1 else lfield env1 0), + lam)) + in + + (* Now we start compiling the class *) let cla = Ident.create "class" in - let (inh_init, obj_init) = build_object_init_0 cla [] cl in + let (inh_init, obj_init) = + build_object_init_0 cla [] cl copy_env subst_env top ids 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 + let (inh_init', cl_init) = + build_class_init cla true (List.rev inh_init) obj_init msubst top cl + in + assert (inh_init' = []); + let table = Ident.create "table" + and class_init = Ident.create (Ident.name cl_id ^ "_init") + and env_init = Ident.create "env_init" + and obj_init = Ident.create "obj_init" in + let pub_meths = + List.sort + (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) + pub_meths in + let tags = List.map Btype.hash_variant pub_meths in + let rev_map = List.combine tags pub_meths in + List.iter2 + (fun tag name -> + let name' = List.assoc tag rev_map in + if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) + tags pub_meths; + let ltable table lam = + Llet(Strict, table, + Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam) + and ldirect obj_init = + Llet(Strict, obj_init, cl_init, + Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), + Lapply(Lvar obj_init, [lambda_unit]))) + in + (* Simplest case: an object defined at toplevel (ids=[]) *) + if top && ids = [] then llets (ltable cla (ldirect obj_init)) else + + let concrete = + ids = [] || + Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = [] + and lclass lam = + let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in + Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) + and lbody fv = + if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then + Lapply (oo_prim "make_class",[transl_meth_list pub_meths; + Lvar class_init]) + else + ltable table ( + Llet( + Strict, env_init, Lapply(Lvar class_init, [Lvar table]), + Lsequence( + Lapply (oo_prim "init_class", [Lvar table]), + Lprim(Pmakeblock(0, Immutable), + [Lapply(Lvar env_init, [lambda_unit]); + Lvar class_init; Lvar env_init; lambda_unit])))) + and lbody_virt lenvs = + Lprim(Pmakeblock(0, Immutable), + [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs]) + in + (* Still easy: a class defined at toplevel *) + if top && concrete then lclass lbody else + if top then llets (lbody_virt lambda_unit) else + + (* Now for the hard stuff: prepare for table cacheing *) + let env_index = Ident.create "env_index" + and envs = Ident.create "envs" in + let lenvs = + if !new_ids_meths = [] && !new_ids_init = [] && inh_init = [] + then lambda_unit + else Lvar envs in + let lenv = + let menv = + if !new_ids_meths = [] then lambda_unit else + Lprim(Pmakeblock(0, Immutable), + List.map (fun id -> Lvar id) !new_ids_meths) in + if !new_ids_init = [] then menv else + Lprim(Pmakeblock(0, Immutable), + menv :: List.map (fun id -> Lvar id) !new_ids_init) + and linh_envs = + List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p])) + (List.rev inh_init) + in + let make_envs lam = + Llet(StrictOpt, envs, + (if linh_envs = [] then lenv else + Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)), + lam) + and def_ids cla lam = + Llet(StrictOpt, env2, + Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]), + lam) + in + let obj_init2 = Ident.create "obj_init" + and cached = Ident.create "cached" in + let inh_paths = + List.filter + (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in + let inh_keys = + List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in + let lclass lam = + Llet(Strict, class_init, + Lfunction(Curried, [cla], def_ids cla cl_init), lam) + and lcache lam = + if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else + Llet(Strict, cached, + Lapply(oo_prim "lookup_tables", + [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]), + lam) + and lset cached i lam = + Lprim(Psetfield(i, true), [Lvar cached; lam]) 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 ldirect () = + ltable cla + (Llet(Strict, env_init, def_ids cla cl_init, + Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), + lset cached 0 (Lvar env_init)))) + and lclass_virt () = + lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init)) + in + llets ( + lcache ( + Lsequence( + Lifthenelse(lfield cached 0, lambda_unit, + if ids = [] then ldirect () else + if not concrete then lclass_virt () else + lclass ( + Lapply (oo_prim "make_class_store", + [transl_meth_list pub_meths; + Lvar class_init; Lvar cached]))), + make_envs ( + if ids = [] then Lapply(lfield cached 0, [lenvs]) else + Lprim(Pmakeblock(0, Immutable), + if concrete then + [Lapply(lfield cached 0, [lenvs]); + lfield cached 1; + lfield cached 0; + lenvs] + else [lambda_unit; lfield cached 0; lambda_unit; lenvs] + ))))) + +(* Dummy for recursive modules *) let dummy_class undef_fn = - Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; oo_prim "dummy_table"]) + Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; undef_fn; lambda_unit]) + +(* Wrapper for class compilation *) + +let transl_class ids cl_id arity pub_meths cl = + oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl + +let () = + transl_object := (fun id meths cl -> transl_class [] id 0 meths cl) (* Error report *) @@ -332,3 +785,6 @@ open Format let report_error ppf = function | Illegal_class_expr -> fprintf ppf "This kind of class expression is not allowed" + | Tags (lab1, lab2) -> + fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" + lab1 lab2 "Change one of them." diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli index a91b7db3..2359ed28 100644 --- a/bytecomp/translclass.mli +++ b/bytecomp/translclass.mli @@ -10,17 +10,16 @@ (* *) (***********************************************************************) -(* $Id: translclass.mli,v 1.8 2003/06/19 15:53:48 xleroy Exp $ *) +(* $Id: translclass.mli,v 1.10 2004/05/26 11:10:50 garrigue 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 +type error = Illegal_class_expr | Tags of string * string exception Error of Location.t * error diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 74f22b74..0ddbeb51 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translcore.ml,v 1.89 2003/06/23 12:45:42 xleroy Exp $ *) +(* $Id: translcore.ml,v 1.96 2004/05/26 11:10:50 garrigue Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the core language *) @@ -36,93 +36,99 @@ let transl_module = ref((fun cc rootpath modl -> assert false) : module_coercion -> Path.t option -> module_expr -> lambda) +let transl_object = + ref (fun id s cl -> assert false : + Ident.t -> string list -> class_expr -> lambda) + (* Translation of primitives *) let comparisons_table = create_hashtable 11 [ "%equal", - (Pccall{prim_name = "equal"; prim_arity = 2; prim_alloc = true; + (Pccall{prim_name = "caml_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; + Pccall{prim_name = "caml_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; + (Pccall{prim_name = "caml_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; + Pccall{prim_name = "caml_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; + (Pccall{prim_name = "caml_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; + Pccall{prim_name = "caml_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; + (Pccall{prim_name = "caml_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; + Pccall{prim_name = "caml_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; + (Pccall{prim_name = "caml_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; + Pccall{prim_name = "caml_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; + (Pccall{prim_name = "caml_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; + Pccall{prim_name = "caml_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; + (Pccall{prim_name = "caml_compare"; prim_arity = 2; prim_alloc = true; prim_native_name = ""; prim_native_float = false}, - Pccall{prim_name = "int_compare"; prim_arity = 2; + Pccall{prim_name = "caml_int_compare"; prim_arity = 2; prim_alloc = false; prim_native_name = ""; prim_native_float = false}, - Pccall{prim_name = "float_compare"; prim_arity = 2; + Pccall{prim_name = "caml_float_compare"; prim_arity = 2; prim_alloc = false; prim_native_name = ""; prim_native_float = false}, - Pccall{prim_name = "string_compare"; prim_arity = 2; + Pccall{prim_name = "caml_string_compare"; prim_arity = 2; prim_alloc = false; prim_native_name = ""; prim_native_float = false}, - Pccall{prim_name = "nativeint_compare"; prim_arity = 2; + Pccall{prim_name = "caml_nativeint_compare"; prim_arity = 2; prim_alloc = false; prim_native_name = ""; prim_native_float = false}, - Pccall{prim_name = "int32_compare"; prim_arity = 2; + Pccall{prim_name = "caml_int32_compare"; prim_arity = 2; prim_alloc = false; prim_native_name = ""; prim_native_float = false}, - Pccall{prim_name = "int64_compare"; prim_arity = 2; + Pccall{prim_name = "caml_int64_compare"; prim_arity = 2; prim_alloc = false; prim_native_name = ""; prim_native_float = false}) ] @@ -246,11 +252,11 @@ let primitives_table = create_hashtable 57 [ ] let prim_makearray = - { prim_name = "make_vect"; prim_arity = 2; prim_alloc = true; + { prim_name = "caml_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_name = "caml_obj_dup"; prim_arity = 1; prim_alloc = true; prim_native_name = ""; prim_native_float = false } let transl_prim prim args = @@ -500,9 +506,30 @@ let assert_failed loc = (* Translation of expressions *) let rec transl_exp e = + let eval_once = + (* Whether classes for immediate objects must be cached *) + match e.exp_desc with + Texp_function _ | Texp_for _ | Texp_while _ -> false + | _ -> true + in + if eval_once then transl_exp0 e else + Translobj.oo_wrap e.exp_env true transl_exp0 e + +and transl_exp0 e = match e.exp_desc with Texp_ident(path, {val_kind = Val_prim p}) -> - transl_primitive p + let public_send = p.prim_name = "%send" in + if public_send || p.prim_name = "%sendself" then + let kind = if public_send then Public else Self in + let obj = Ident.create "obj" and meth = Ident.create "meth" in + Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [])) + else if p.prim_name = "%sendcache" then + let obj = Ident.create "obj" and meth = Ident.create "meth" in + let cache = Ident.create "cache" and pos = Ident.create "pos" in + Lfunction(Curried, [obj; meth; cache; pos], + Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos])) + else + 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 _}) -> @@ -524,14 +551,26 @@ let rec transl_exp e = 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) + let argl = transl_list args in + let public_send = p.prim_name = "%send" + || not !Clflags.native_code && p.prim_name = "%sendcache"in + if public_send || p.prim_name = "%sendself" then + let kind = if public_send then Public else Self in + let obj = List.hd argl in + event_after e (Lsend (kind, List.nth argl 1, obj, [])) + else if p.prim_name = "%sendcache" then + match argl with [obj; meth; cache; pos] -> + event_after e (Lsend(Cached, meth, obj, [cache; pos])) + | _ -> assert false + else begin + let prim = transl_prim p args in + match (prim, args) with + (Praise, [arg1]) -> + Lprim(Praise, [event_after arg1 (List.hd argl)]) + | (_, _) -> + if primitive_is_ccall prim + then event_after e (Lprim(prim, argl)) + else Lprim(prim, argl) end | Texp_apply(funct, oargs) -> event_after e (transl_apply (transl_exp funct) oargs) @@ -600,7 +639,7 @@ let rec transl_exp e = 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; + if List.length ll <= 4 then raise Not_constant; let cl = List.map extract_constant ll in let master = match kind with @@ -609,7 +648,7 @@ let rec transl_exp e = | Pfloatarray -> Lconst(Const_float_array(List.map extract_float cl)) | Pgenarray -> - assert false in + raise Not_constant in (* can this really happen? *) Lprim(Pccall prim_obj_dup, [master]) with Not_constant -> Lprim(Pmakearray kind, ll) @@ -634,12 +673,16 @@ let rec transl_exp e = (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 + let obj = transl_exp expr in + let lam = + match met with + Tmeth_val id -> Lsend (Self, Lvar id, obj, []) + | Tmeth_name nm -> + let (tag, cache) = Translobj.meth obj nm in + let kind = if cache = [] then Public else Cached in + Lsend (kind, tag, obj, cache) in - event_after e (Lsend(Lvar met_id, transl_exp expr, [])) + event_after e lam | Texp_new (cl, _) -> Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit]) | Texp_instvar(path_self, path) -> @@ -665,6 +708,13 @@ let rec transl_exp e = | Texp_lazy e -> let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]) + | Texp_object (cs, cty, meths) -> + let cl = Ident.create "class" in + !transl_object cl meths + { cl_desc = Tclass_structure cs; + cl_loc = e.exp_loc; + cl_type = Tcty_signature cty; + cl_env = e.exp_env } and transl_list expr_list = List.map transl_exp expr_list @@ -680,10 +730,10 @@ and transl_tupled_cases 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) + Lsend(k, lmet, lobj, largs) -> + Lsend(k, lmet, lobj, largs @ args) + | Levent(Lsend(k, lmet, lobj, largs), _) -> + Lsend(k, lmet, lobj, largs @ args) | Lapply(lexp, largs) -> Lapply(lexp, largs @ args) | lexp -> @@ -735,33 +785,6 @@ and transl_function loc untuplify_fn repr partial pat_expr_list = 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 @@ -877,6 +900,19 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = end end +(* Wrapper for class compilation *) + +(* +let transl_exp = transl_exp_wrap + +let transl_let rec_flag pat_expr_list body = + match pat_expr_list with + [] -> body + | (_, expr) :: _ -> + Translobj.oo_wrap expr.exp_env false + (transl_let rec_flag pat_expr_list) body +*) + (* Compile an exception definition *) let transl_exception id path decl = diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 2b7d01d0..c7609879 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translcore.mli,v 1.17 2000/09/04 08:49:31 garrigue Exp $ *) +(* $Id: translcore.mli,v 1.18 2003/11/25 09:20:43 garrigue Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the core language *) @@ -46,3 +46,5 @@ 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 +val transl_object : + (Ident.t -> string list -> class_expr -> lambda) ref diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 43b68266..abd02496 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translmod.ml,v 1.45 2003/10/03 14:36:00 xleroy Exp $ *) +(* $Id: translmod.ml,v 1.50 2004/06/12 08:55:45 xleroy Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the module language *) @@ -138,21 +138,21 @@ let init_value modl = [Lvar undef_function_id]) | _ -> raise Not_found in init_v :: init_value_struct env rem - | Tsig_type(id, tdecl) :: 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 -> + | 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 -> + | Tsig_class(id, cdecl, _) :: rem -> Translclass.dummy_class (Lvar undef_function_id) :: init_value_struct env rem - | Tsig_cltype(id, ctyp) :: rem -> + | Tsig_cltype(id, ctyp, _) :: rem -> init_value_struct env rem in try @@ -198,7 +198,7 @@ let reorder_rec_bindings bindings = (* Generate lambda-code for a reordered list of bindings *) let prim_update = - { prim_name = "update_dummy"; + { prim_name = "caml_update_dummy"; prim_arity = 2; prim_alloc = true; prim_native_name = ""; @@ -248,19 +248,22 @@ let rec transl_module cc rootpath mexp = 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 + oo_wrap mexp.mod_env true + (function + | 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") + cc | Tmod_apply(funct, arg, ccarg) -> - apply_coercion cc + oo_wrap mexp.mod_env true + (apply_coercion cc) (Lapply(transl_module Tcoerce_none None funct, [transl_module ccarg None arg])) | Tmod_constraint(arg, mty, ccarg) -> @@ -537,7 +540,9 @@ let transl_store_implementation module_name (str, restr) = 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)) + transl_store_label_init module_id size + (transl_store_structure module_id map prims) str + (*size, transl_label_init (transl_store_structure module_id map prims str)*) (* Compile a toplevel phrase *) @@ -635,15 +640,19 @@ let transl_toplevel_definition str = (* Compile the initialization code for a packed library *) +let get_component = function + None -> Lconst const_unit + | Some id -> Lprim(Pgetglobal id, []) + let transl_package component_names target_name coercion = let components = match coercion with Tcoerce_none -> - List.map (fun id -> Lprim(Pgetglobal id, [])) component_names + List.map get_component 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), []))) + (fun (pos, cc) -> apply_coercion cc (get_component g.(pos))) pos_cc_list | _ -> assert false in @@ -661,7 +670,7 @@ let transl_store_package component_names target_name coercion = (fun pos id -> Lprim(Psetfield(pos, false), [Lprim(Pgetglobal target_name, []); - Lprim(Pgetglobal id, [])])) + get_component id])) 0 component_names) | Tcoerce_structure pos_cc_list -> let id = Array.of_list component_names in @@ -670,7 +679,7 @@ let transl_store_package component_names target_name coercion = (fun dst (src, cc) -> Lprim(Psetfield(dst, false), [Lprim(Pgetglobal target_name, []); - apply_coercion cc (Lprim(Pgetglobal id.(src), []))])) + apply_coercion cc (get_component id.(src))])) 0 pos_cc_list) | _ -> assert false diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 402e2fea..95ddffad 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translmod.mli,v 1.11 2003/06/19 15:53:48 xleroy Exp $ *) +(* $Id: translmod.mli,v 1.12 2004/04/09 13:32:27 xleroy Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the module language *) @@ -22,9 +22,10 @@ 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_package: + Ident.t option list -> Ident.t -> module_coercion -> lambda val transl_store_package: - Ident.t list -> Ident.t -> module_coercion -> int * lambda + Ident.t option list -> Ident.t -> module_coercion -> int * lambda val toplevel_name: Ident.t -> string diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 2013cbbc..5554ad1a 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -10,9 +10,10 @@ (* *) (***********************************************************************) -(* $Id: translobj.ml,v 1.7 2002/04/24 09:49:05 xleroy Exp $ *) +(* $Id: translobj.ml,v 1.9 2004/05/26 11:10:51 garrigue Exp $ *) open Misc +open Primitive open Asttypes open Longident open Lambda @@ -26,37 +27,132 @@ let oo_prim name = with Not_found -> fatal_error ("Primitive " ^ name ^ " not found.") +(* Share blocks *) + +let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17 + +let share c = + match c with + Const_block (n, l) when l <> [] -> + begin try + Lvar (Hashtbl.find consts c) + with Not_found -> + let id = Ident.create "shared" in + Hashtbl.add consts c id; + Lvar id + end + | _ -> Lconst c + (* Collect labels *) -let used_methods = ref ([] : (string * Ident.t) list);; +let cache_required = ref false +let method_cache = ref lambda_unit +let method_count = ref 0 +let method_table = ref [] + +let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s))) + +let next_cache tag = + let n = !method_count in + incr method_count; + (tag, [!method_cache; Lconst(Const_base(Const_int n))]) + +let rec is_path = function + Lvar _ | Lprim (Pgetglobal _, []) | Lconst _ -> true + | Lprim (Pfield _, [lam]) -> is_path lam + | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2]) -> + is_path lam1 && is_path lam2 + | _ -> false -let meth lab = +let meth obj lab = + let tag = meth_tag lab in + if not (!cache_required && !Clflags.native_code) then (tag, []) else + if not (is_path obj) then next_cache tag else try - List.assoc lab !used_methods + let r = List.assoc obj !method_table in + try + (tag, List.assoc tag !r) + with Not_found -> + let p = next_cache tag in + r := p :: !r; + p with Not_found -> - let id = Ident.create lab in - used_methods := (lab, id)::!used_methods; - id + let p = next_cache tag in + method_table := (obj, ref [p]) :: !method_table; + p let reset_labels () = - used_methods := [] + Hashtbl.clear consts; + method_count := 0; + method_table := [] (* Insert labels *) let string s = Lconst (Const_base (Const_string s)) +let int n = Lconst (Const_base (Const_int n)) + +let prim_makearray = + { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false } 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) + let expr = + Hashtbl.fold + (fun c id expr -> Llet(Alias, id, Lconst c, expr)) + consts expr + in + reset_labels (); + expr + +let transl_store_label_init glob size f arg = + method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]); + let expr = f arg in + let (size, expr) = + if !method_count = 0 then (size, expr) else + (size+1, + Lsequence( + Lprim(Psetfield(size, false), + [Lprim(Pgetglobal glob, []); + Lprim (Pccall prim_makearray, [int !method_count; int 0])]), + expr)) + in + (size, transl_label_init expr) + +(* Share classes *) + +let wrapping = ref false +let top_env = ref Env.empty +let classes = ref [] + +let oo_add_class id = + classes := id :: !classes; + (!top_env, !cache_required) + +let oo_wrap env req f x = + if !wrapping then + if !cache_required then f x else + try cache_required := true; let lam = f x in cache_required := false; lam + with exn -> cache_required := false; raise exn + else try + wrapping := true; + cache_required := req; + top_env := env; + classes := []; + let lambda = f x in + let lambda = + List.fold_left + (fun lambda id -> + Llet(StrictOpt, id, + Lprim(Pmakeblock(0, Mutable), + [lambda_unit; lambda_unit; lambda_unit]), + lambda)) + lambda !classes in - reset_labels (); - expr' + wrapping := false; + top_env := Env.empty; + lambda + with exn -> + wrapping := false; + top_env := Env.empty; + raise exn + diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index acb5bc98..9d324364 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -10,11 +10,19 @@ (* *) (***********************************************************************) -(* $Id: translobj.mli,v 1.4 1999/11/17 18:57:03 xleroy Exp $ *) +(* $Id: translobj.mli,v 1.6 2004/05/26 11:10:51 garrigue Exp $ *) -val oo_prim: string -> Lambda.lambda +open Lambda -val meth: string -> Ident.t +val oo_prim: string -> lambda + +val share: structured_constant -> lambda +val meth: lambda -> string -> lambda * lambda list val reset_labels: unit -> unit -val transl_label_init: Lambda.lambda -> Lambda.lambda +val transl_label_init: lambda -> lambda +val transl_store_label_init: + Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda + +val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda +val oo_add_class: Ident.t -> Env.t * bool diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index 997a00dc..7dcc2649 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typeopt.ml,v 1.9 2003/07/02 09:14:29 xleroy Exp $ *) +(* $Id: typeopt.ml,v 1.10 2004/04/16 00:50:23 garrigue Exp $ *) (* Auxiliaries for type-based optimizations, e.g. array kinds *) @@ -87,7 +87,8 @@ let array_element_kind env ty = 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 -> + Tconstr(p, [elt_ty], _) | Tpoly({desc = 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 *) diff --git a/byterun/.depend b/byterun/.depend index e80d3cfa..c9b0e099 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -1,249 +1,266 @@ -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 \ +alloc.o: alloc.c alloc.h compatibility.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 compatibility.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 -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 \ +backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ + compatibility.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 compatibility.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 compatibility.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 compatibility.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 compatibility.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 \ + compatibility.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 compatibility.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 compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h +fail.o: fail.c alloc.h compatibility.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 compatibility.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 \ + compatibility.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 compatibility.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 \ + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h +gc_ctrl.o: gc_ctrl.c alloc.h compatibility.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 compatibility.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 compatibility.h config.h ../config/m.h \ + ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h -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 +intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h +interp.o: interp.c alloc.h compatibility.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 compatibility.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 compatibility.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 compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +main.o: main.c misc.h compatibility.h config.h ../config/m.h \ + ../config/s.h mlvalues.h sys.h major_gc.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - 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 \ + compatibility.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 compatibility.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 compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ + minor_gc.h signals.h +meta.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ + major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h +minor_gc.o: minor_gc.c config.h ../config/m.h ../config/s.h \ + compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h +misc.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ + misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h +obj.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ + memory.h minor_gc.h prims.h +parsing.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ + mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + alloc.h +prims.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ + ../config/s.h misc.h prims.h +printexc.o: printexc.c backtrace.h mlvalues.h compatibility.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 compatibility.h config.h \ + ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h globroots.h stacks.h +signals.o: signals.c alloc.h compatibility.h misc.h config.h \ + ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h roots.h signals.h sys.h +stacks.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.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 compatibility.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 compatibility.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 compatibility.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 \ + compatibility.h alloc.h misc.h mlvalues.h fail.h io.h +unix.o: unix.c config.h ../config/m.h ../config/s.h compatibility.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 compatibility.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 compatibility.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 compatibility.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 compatibility.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 \ + compatibility.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 compatibility.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 compatibility.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 compatibility.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 compatibility.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 \ + compatibility.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 compatibility.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 compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h +fail.d.o: fail.c alloc.h compatibility.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 compatibility.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 \ + compatibility.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 compatibility.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 \ + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h +gc_ctrl.d.o: gc_ctrl.c alloc.h compatibility.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 -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 \ +globroots.d.o: globroots.c memory.h compatibility.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 compatibility.h config.h ../config/m.h \ + ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h -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 \ +instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \ + ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h +intern.d.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h +interp.d.o: interp.c alloc.h compatibility.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 compatibility.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 compatibility.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 compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h -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 +main.d.o: main.c misc.h compatibility.h config.h ../config/m.h \ + ../config/s.h mlvalues.h sys.h major_gc.d.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - 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 + compatibility.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 compatibility.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 compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ + minor_gc.h signals.h +meta.d.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ + major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h +minor_gc.d.o: minor_gc.c config.h ../config/m.h ../config/s.h \ + compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h +misc.d.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ + misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h +obj.d.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ + memory.h minor_gc.h prims.h +parsing.d.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ + mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + alloc.h +prims.d.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ + ../config/s.h misc.h prims.h +printexc.d.o: printexc.c backtrace.h mlvalues.h compatibility.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 compatibility.h config.h \ + ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h globroots.h stacks.h +signals.d.o: signals.c alloc.h compatibility.h misc.h config.h \ + ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h roots.h signals.h sys.h +stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.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 compatibility.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 compatibility.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 compatibility.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 \ + compatibility.h alloc.h misc.h mlvalues.h fail.h io.h +unix.d.o: unix.c config.h ../config/m.h ../config/s.h compatibility.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 compatibility.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 compatibility.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 index 61e5bca6..9955d8dd 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -11,13 +11,13 @@ # # ######################################################################### -# $Id: Makefile,v 1.45 2003/06/23 12:52:06 xleroy Exp $ +# $Id: Makefile,v 1.48 2004/05/09 10:37:27 xleroy Exp $ include ../config/Makefile CC=$(BYTECC) -CFLAGS=-O $(BYTECCCOMPOPTS) -DFLAGS=-g -DDEBUG $(BYTECCCOMPOPTS) +CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) +DFLAGS=-DCAML_NAME_SPACE -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 \ @@ -35,7 +35,7 @@ PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.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 + memory.h misc.h mlvalues.h signals.h compatibility.h all: ocamlrun$(EXE) @@ -76,14 +76,15 @@ prims.c : primitives (echo '#include "mlvalues.h"'; \ echo '#include "prims.h"'; \ sed -e 's/.*/extern value &();/' primitives; \ - echo 'c_primitive builtin_cprim[] = {'; \ + echo 'c_primitive caml_builtin_cprim[] = {'; \ sed -e 's/.*/ &,/' primitives; \ echo ' 0 };'; \ - echo 'char * names_of_builtin_cprim[] = {'; \ + echo 'char * caml_names_of_builtin_cprim[] = {'; \ sed -e 's/.*/ "&",/' primitives; \ echo ' 0 };') > prims.c opnames.h : instruct.h + LANG=C; \ sed -e '/\/\*/d' \ -e '/^#/d' \ -e 's/enum /char * names_of_/' \ diff --git a/byterun/Makefile.Mac b/byterun/Makefile.Mac deleted file mode 100644 index 4a439ea2..00000000 --- a/byterun/Makefile.Mac +++ /dev/null @@ -1,118 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../LICENSE. # -# # -######################################################################### - -# $Id: 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 deleted file mode 100644 index 7f018d36..00000000 --- a/byterun/Makefile.Mac.depend +++ /dev/null @@ -1,1180 +0,0 @@ -#*** 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 index b7c44016..8c7333bb 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.33 2002/06/17 12:24:42 xleroy Exp $ +# $Id: Makefile.nt,v 1.36 2004/05/04 09:03:25 xleroy Exp $ include ../config/Makefile @@ -35,7 +35,7 @@ PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ dynlink.c PUBLIC_INCLUDES=alloc.h callback.h config.h custom.h fail.h intext.h \ - memory.h misc.h mlvalues.h + memory.h misc.h mlvalues.h signals.h compatibility.h all: ocamlrun.exe libcamlrun.$(A) @@ -68,10 +68,10 @@ prims.c : primitives (echo '#include "mlvalues.h"'; \ echo '#include "prims.h"'; \ sed -e 's/.*/extern value &();/' primitives; \ - echo 'c_primitive builtin_cprim[] = {'; \ + echo 'c_primitive caml_builtin_cprim[] = {'; \ sed -e 's/.*/ &,/' primitives; \ echo ' 0 };'; \ - echo 'char * names_of_builtin_cprim[] = {'; \ + echo 'char * caml_names_of_builtin_cprim[] = {'; \ sed -e 's/.*/ "&",/' primitives; \ echo ' 0 };') > prims.c diff --git a/byterun/alloc.c b/byterun/alloc.c index 7de5b2f8..cac5b072 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: alloc.c,v 1.25 2002/01/18 15:13:25 doligez Exp $ */ +/* $Id: alloc.c,v 1.28 2004/01/01 16:42:34 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. @@ -29,7 +29,7 @@ #define Setup_for_gc #define Restore_after_gc -CAMLexport value alloc (mlsize_t wosize, tag_t tag) +CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag) { value result; mlsize_t i; @@ -44,14 +44,14 @@ CAMLexport value alloc (mlsize_t wosize, tag_t tag) for (i = 0; i < wosize; i++) Field (result, i) = 0; } }else{ - result = alloc_shr (wosize, tag); + result = caml_alloc_shr (wosize, tag); if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize)); - result = check_urgent_gc (result); + result = caml_check_urgent_gc (result); } return result; } -CAMLexport value alloc_small (mlsize_t wosize, tag_t tag) +CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag) { value result; @@ -62,12 +62,12 @@ CAMLexport value alloc_small (mlsize_t wosize, tag_t tag) return result; } -CAMLexport value alloc_tuple(mlsize_t n) +CAMLexport value caml_alloc_tuple(mlsize_t n) { - return alloc(n, 0); + return caml_alloc(n, 0); } -CAMLexport value alloc_string (mlsize_t len) +CAMLexport value caml_alloc_string (mlsize_t len) { value result; mlsize_t offset_index; @@ -76,8 +76,8 @@ CAMLexport value alloc_string (mlsize_t len) if (wosize <= Max_young_wosize) { Alloc_small (result, wosize, String_tag); }else{ - result = alloc_shr (wosize, String_tag); - result = check_urgent_gc (result); + result = caml_alloc_shr (wosize, String_tag); + result = caml_check_urgent_gc (result); } Field (result, wosize - 1) = 0; offset_index = Bsize_wsize (wosize) - 1; @@ -85,25 +85,26 @@ CAMLexport value alloc_string (mlsize_t len) return result; } -CAMLexport value alloc_final (mlsize_t len, final_fun fun, - mlsize_t mem, mlsize_t max) +CAMLexport value caml_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); + return caml_alloc_custom(caml_final_custom_operations(fun), + len * sizeof(value), mem, max); } -CAMLexport value copy_string(char const *s) +CAMLexport value caml_copy_string(char const *s) { int len; value res; len = strlen(s); - res = alloc_string(len); + res = caml_alloc_string(len); memmove(String_val(res), s, len); return res; } -CAMLexport value alloc_array(value (*funct)(char const *), char const ** arr) +CAMLexport value caml_alloc_array(value (*funct)(char const *), + char const ** arr) { CAMLparam0 (); mlsize_t nbr, n; @@ -114,24 +115,24 @@ CAMLexport value alloc_array(value (*funct)(char const *), char const ** arr) if (nbr == 0) { CAMLreturn (Atom(0)); } else { - result = alloc (nbr, 0); + result = caml_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); + caml_modify(&Field(result, n), v); } CAMLreturn (result); } } -CAMLexport value copy_string_array(char const ** arr) +CAMLexport value caml_copy_string_array(char const ** arr) { - return alloc_array(copy_string, arr); + return caml_alloc_array(caml_copy_string, arr); } -CAMLexport int convert_flag_list(value list, int *flags) +CAMLexport int caml_convert_flag_list(value list, int *flags) { int res; res = 0; @@ -144,21 +145,21 @@ CAMLexport int convert_flag_list(value list, int *flags) /* For compiling let rec over values */ -CAMLprim value alloc_dummy(value size) +CAMLprim value caml_alloc_dummy(value size) { mlsize_t wosize = Int_val(size); if (wosize == 0) return Atom(0); - return alloc (wosize, 0); + return caml_alloc (wosize, 0); } -CAMLprim value update_dummy(value dummy, value newval) +CAMLprim value caml_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)); + caml_modify(&Field(dummy, i), Field(newval, i)); return Val_unit; } diff --git a/byterun/alloc.h b/byterun/alloc.h index a84474f9..4634b28f 100644 --- a/byterun/alloc.h +++ b/byterun/alloc.h @@ -11,34 +11,37 @@ /* */ /***********************************************************************/ -/* $Id: alloc.h,v 1.13 2002/11/04 13:58:10 doligez Exp $ */ +/* $Id: alloc.h,v 1.17 2004/01/02 19:23:18 doligez Exp $ */ -#ifndef _alloc_ -#define _alloc_ +#ifndef CAML_ALLOC_H +#define CAML_ALLOC_H +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif #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); +CAMLextern value caml_alloc (mlsize_t, tag_t); +CAMLextern value caml_alloc_small (mlsize_t, tag_t); +CAMLextern value caml_alloc_tuple (mlsize_t); +CAMLextern value caml_alloc_string (mlsize_t); /* size in bytes */ +CAMLextern value caml_copy_string (char const *); +CAMLextern value caml_copy_string_array (char const **); +CAMLextern value caml_copy_double (double); +CAMLextern value caml_copy_int32 (int32); /* defined in [ints.c] */ +CAMLextern value caml_copy_int64 (int64); /* defined in [ints.c] */ +CAMLextern value caml_copy_nativeint (long); /* defined in [ints.c] */ +CAMLextern value caml_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 value caml_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 *); +CAMLextern int caml_convert_flag_list (value, int *); -#endif /* _alloc_ */ +#endif /* CAML_ALLOC_H */ diff --git a/byterun/array.c b/byterun/array.c index 506ec3cc..46fb8832 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: array.c,v 1.17 2001/12/07 13:39:22 xleroy Exp $ */ +/* $Id: array.c,v 1.22 2004/01/02 19:23:19 doligez Exp $ */ /* Operations on arrays */ @@ -23,21 +23,21 @@ #ifndef NATIVE_CODE -CAMLprim value array_get_addr(value array, value index) +CAMLprim value caml_array_get_addr(value array, value index) { long idx = Long_val(index); - if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.get"); + if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error(); return Field(array, idx); } -CAMLprim value array_get_float(value array, value index) +CAMLprim value caml_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"); + if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) + caml_array_bound_error(); d = Double_field(array, idx); #define Setup_for_gc #define Restore_after_gc @@ -48,40 +48,40 @@ CAMLprim value array_get_float(value array, value index) return res; } -CAMLprim value array_get(value array, value index) +CAMLprim value caml_array_get(value array, value index) { if (Tag_val(array) == Double_array_tag) - return array_get_float(array, index); + return caml_array_get_float(array, index); else - return array_get_addr(array, index); + return caml_array_get_addr(array, index); } -CAMLprim value array_set_addr(value array, value index, value newval) +CAMLprim value caml_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"); + if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error(); Modify(&Field(array, idx), newval); return Val_unit; } -CAMLprim value array_set_float(value array, value index, value newval) +CAMLprim value caml_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"); + caml_array_bound_error(); Store_double_field(array, idx, Double_val(newval)); return Val_unit; } -CAMLprim value array_set(value array, value index, value newval) +CAMLprim value caml_array_set(value array, value index, value newval) { if (Tag_val(array) == Double_array_tag) - return array_set_float(array, index, newval); + return caml_array_set_float(array, index, newval); else - return array_set_addr(array, index, newval); + return caml_array_set_addr(array, index, newval); } -CAMLprim value array_unsafe_get_float(value array, value index) +CAMLprim value caml_array_unsafe_get_float(value array, value index) { double d; value res; @@ -96,38 +96,38 @@ CAMLprim value array_unsafe_get_float(value array, value index) return res; } -CAMLprim value array_unsafe_get(value array, value index) +CAMLprim value caml_array_unsafe_get(value array, value index) { if (Tag_val(array) == Double_array_tag) - return array_unsafe_get_float(array, index); + return caml_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) +CAMLprim value caml_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) +CAMLprim value caml_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) +CAMLprim value caml_array_unsafe_set(value array, value index, value newval) { if (Tag_val(array) == Double_array_tag) - return array_unsafe_set_float(array, index, newval); + return caml_array_unsafe_set_float(array, index, newval); else - return array_unsafe_set_addr(array, index, newval); + return caml_array_unsafe_set_addr(array, index, newval); } #endif -CAMLprim value make_vect(value len, value init) +CAMLprim value caml_make_vect(value len, value init) { CAMLparam2 (len, init); CAMLlocal1 (res); @@ -143,33 +143,33 @@ CAMLprim value make_vect(value len, value 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); + if (wsize > Max_wosize) caml_invalid_argument("Array.make"); + res = caml_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_wosize) caml_invalid_argument("Array.make"); if (size < Max_young_wosize) { - res = alloc_small(size, 0); + res = caml_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); + caml_minor_collection(); + res = caml_alloc_shr(size, 0); for (i = 0; i < size; i++) Field(res, i) = init; - res = check_urgent_gc (res); + res = caml_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); + res = caml_alloc_shr(size, 0); + for (i = 0; i < size; i++) caml_initialize(&Field(res, i), init); + res = caml_check_urgent_gc (res); } } CAMLreturn (res); } -CAMLprim value make_array(value init) +CAMLprim value caml_make_array(value init) { CAMLparam1 (init); mlsize_t wsize, size, i; @@ -187,7 +187,7 @@ CAMLprim value make_array(value init) } else { Assert(size < Max_young_wosize); wsize = size * Double_wosize; - res = alloc_small(wsize, Double_array_tag); + res = caml_alloc_small(wsize, Double_array_tag); for (i = 0; i < size; i++) { Store_double_field(res, i, Double_val(Field(init, i))); } diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 2bd7f758..042cdd2f 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: backtrace.c,v 1.16 2003/02/24 16:44:47 doligez Exp $ */ +/* $Id: backtrace.c,v 1.20 2004/01/02 19:23:19 doligez Exp $ */ /* Stack backtrace for uncaught exceptions */ @@ -34,10 +34,10 @@ #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; +CAMLexport int caml_backtrace_active = 0; +CAMLexport int caml_backtrace_pos = 0; +CAMLexport code_t * caml_backtrace_buffer = NULL; +CAMLexport value caml_backtrace_last_exn = Val_unit; #define BACKTRACE_BUFFER_SIZE 1024 /* Location of fields in the Instruct.debug_event record */ @@ -56,38 +56,38 @@ enum { /* Initialize the backtrace machinery */ -void init_backtrace(void) +void caml_init_backtrace(void) { - backtrace_active = 1; - register_global_root(&backtrace_last_exn); - /* Note: lazy initialization of backtrace_buffer in stash_backtrace + caml_backtrace_active = 1; + caml_register_global_root(&caml_backtrace_last_exn); + /* Note: lazy initialization of caml_backtrace_buffer in caml_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) +void caml_stash_backtrace(value exn, code_t pc, value * sp) { - code_t end_code = (code_t) ((char *) start_code + code_size); + code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); if (pc != NULL) pc = pc - 1; - if (exn != backtrace_last_exn) { - backtrace_pos = 0; - backtrace_last_exn = exn; + if (exn != caml_backtrace_last_exn) { + caml_backtrace_pos = 0; + caml_backtrace_last_exn = exn; } - if (backtrace_buffer == NULL) { - backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); - if (backtrace_buffer == NULL) return; + if (caml_backtrace_buffer == NULL) { + caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); + if (caml_backtrace_buffer == NULL) return; } - if (backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; - if (pc >= start_code && pc < end_code){ - backtrace_buffer[backtrace_pos++] = pc; + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; + if (pc >= caml_start_code && pc < end_code){ + caml_backtrace_buffer[caml_backtrace_pos++] = pc; } - for (/*nothing*/; sp < trapsp; sp++) { + for (/*nothing*/; sp < caml_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; + if (p >= caml_start_code && p < end_code) { + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break; + caml_backtrace_buffer[caml_backtrace_pos++] = p; } } } @@ -112,19 +112,19 @@ static value read_debug_info(void) value evl, l; exec_name = caml_exe_name; - fd = attempt_open(&exec_name, &trail, 1); + fd = caml_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) { + caml_read_section_descriptors(fd, &trail); + if (caml_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); + chan = caml_open_descriptor_in(fd); + num_events = caml_getword(chan); + events = caml_alloc(num_events, 0); for (i = 0; i < num_events; i++) { - orig = getword(chan); - evl = input_val(chan); + orig = caml_getword(chan); + evl = caml_input_val(chan); /* Relocate events in event list */ for (l = evl; l != Val_int(0); l = Field(l, 1)) { value ev = Field(l, 0); @@ -133,7 +133,7 @@ static value read_debug_info(void) /* Record event list */ Store_field(events, i, evl); } - close_channel(chan); + caml_close_channel(chan); CAMLreturn(events); } @@ -144,8 +144,8 @@ 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); + Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size); + pos = Val_long((char *) pc - (char *) caml_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); @@ -162,12 +162,12 @@ static value event_for_location(value events, code_t pc) static void print_location(value events, int index) { - code_t pc = backtrace_buffer[index]; + code_t pc = caml_backtrace_buffer[index]; char * info; value ev; ev = event_for_location(events, pc); - if (is_instruction(*pc, RAISE)) { + if (caml_is_instruction(*pc, RAISE)) { /* Ignore compiler-inserted raise */ if (ev == Val_false) return; /* Initial raise if index == 0, re-raise otherwise */ @@ -196,7 +196,7 @@ static void print_location(value events, int index) /* Print a backtrace */ -CAMLexport void print_exception_backtrace(void) +CAMLexport void caml_print_exception_backtrace(void) { value events; int i; @@ -207,6 +207,6 @@ CAMLexport void print_exception_backtrace(void) "(Program not linked with -g, cannot print stack backtrace)\n"); return; } - for (i = 0; i < backtrace_pos; i++) + for (i = 0; i < caml_backtrace_pos; i++) print_location(events, i); } diff --git a/byterun/backtrace.h b/byterun/backtrace.h index 8040627b..9d267800 100644 --- a/byterun/backtrace.h +++ b/byterun/backtrace.h @@ -1,15 +1,30 @@ -#ifndef _backtrace_ -#define _backtrace_ +/***********************************************************************/ +/* */ +/* 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: backtrace.h,v 1.6 2003/12/31 14:20:35 doligez Exp $ */ + +#ifndef CAML_BACKTRACE_H +#define CAML_BACKTRACE_H #include "mlvalues.h" -CAMLextern int backtrace_active; -CAMLextern int backtrace_pos; -CAMLextern code_t * backtrace_buffer; -CAMLextern value backtrace_last_exn; +CAMLextern int caml_backtrace_active; +CAMLextern int caml_backtrace_pos; +CAMLextern code_t * caml_backtrace_buffer; +CAMLextern value caml_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); +extern void caml_init_backtrace(void); +extern void caml_stash_backtrace(value exn, code_t pc, value * sp); +CAMLextern void caml_print_exception_backtrace(void); -#endif +#endif /* CAML_BACKTRACE_H */ diff --git a/byterun/callback.c b/byterun/callback.c index 69ab25fd..5aef75c9 100644 --- a/byterun/callback.c +++ b/byterun/callback.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: callback.c,v 1.15 2002/07/11 15:37:18 xleroy Exp $ */ +/* $Id: callback.c,v 1.22 2004/04/26 12:02:07 basile Exp $ */ /* Callbacks from C to Caml */ @@ -30,9 +30,12 @@ #include "fix_code.h" #include "stacks.h" -int callback_depth = 0; +CAMLexport int caml_callback_depth = 0; +#ifndef LOCAL_CALLBACK_BYTECODE static opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP }; +#endif + #ifdef THREADED_CODE @@ -40,7 +43,7 @@ static int callback_code_threaded = 0; static void thread_callback(void) { - thread_code(callback_code, sizeof(callback_code)); + caml_thread_code(callback_code, sizeof(callback_code)); callback_code_threaded = 1; } @@ -52,56 +55,83 @@ static void thread_callback(void) #endif -CAMLexport value callbackN_exn(value closure, int narg, value args[]) +CAMLexport value caml_callbackN_exn(value closure, int narg, value args[]) { int i; value res; + /* some alternate bytecode implementations (e.g. a JIT translator) + might require that the bytecode is kept in a local variable on + the C stack */ +#ifdef LOCAL_CALLBACK_BYTECODE + opcode_t local_callback_code[7]; +#endif + Assert(narg + 4 <= 256); + + caml_extern_sp -= narg + 4; + for (i = 0; i < narg; i++) caml_extern_sp[i] = args[i]; /* arguments */ +#ifndef LOCAL_CALLBACK_BYTECODE + caml_extern_sp[narg] = (value) (callback_code + 4); /* return address */ + caml_extern_sp[narg + 1] = Val_unit; /* environment */ + caml_extern_sp[narg + 2] = Val_long(0); /* extra args */ + caml_extern_sp[narg + 3] = closure; 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 */ + res = caml_interprete(callback_code, sizeof(callback_code)); +#else /*have LOCAL_CALLBACK_BYTECODE*/ + caml_extern_sp[narg] = (value) (local_callback_code + 4); /* return address */ + caml_extern_sp[narg + 1] = Val_unit; /* environment */ + caml_extern_sp[narg + 2] = Val_long(0); /* extra args */ + caml_extern_sp[narg + 3] = closure; + local_callback_code[0] = ACC; + local_callback_code[1] = narg + 3; + local_callback_code[2] = APPLY; + local_callback_code[3] = narg; + local_callback_code[4] = POP; + local_callback_code[5] = 1; + local_callback_code[6] = STOP; +#ifdef THREADED_CODE + caml_thread_code(local_callback_code, sizeof(local_callback_code)); +#endif /*THREADED_CODE*/ + res = caml_interprete(local_callback_code, sizeof(local_callback_code)); + caml_release_bytecode(local_callback_code, sizeof(local_callback_code)); +#endif /*LOCAL_CALLBACK_BYTECODE*/ + if (Is_exception_result(res)) caml_extern_sp += narg + 4; /* PR#1228 */ return res; } -CAMLexport value callback_exn(value closure, value arg1) +CAMLexport value caml_callback_exn(value closure, value arg1) { value arg[1]; arg[0] = arg1; - return callbackN_exn(closure, 1, arg); + return caml_callbackN_exn(closure, 1, arg); } -CAMLexport value callback2_exn(value closure, value arg1, value arg2) +CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2) { value arg[2]; arg[0] = arg1; arg[1] = arg2; - return callbackN_exn(closure, 2, arg); + return caml_callbackN_exn(closure, 2, arg); } -CAMLexport value callback3_exn(value closure, +CAMLexport value caml_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); + return caml_callbackN_exn(closure, 3, arg); } #else -/* Native-code callbacks. callback[123]_exn are implemented in asm. */ +/* Native-code callbacks. caml_callback[123]_exn are implemented in asm. */ -CAMLexport value callbackN_exn(value closure, int narg, value args[]) +CAMLexport value caml_callbackN_exn(value closure, int narg, value args[]) { CAMLparam1 (closure); CAMLxparamN (args, narg); @@ -113,17 +143,17 @@ CAMLexport value callbackN_exn(value closure, int narg, value args[]) /* Pass as many arguments as possible */ switch (narg - i) { case 1: - res = callback_exn(res, args[i]); + res = caml_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]); + res = caml_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]); + res = caml_callback3_exn(res, args[i], args[i + 1], args[i + 2]); if (Is_exception_result(res)) CAMLreturn (res); i += 3; break; @@ -136,31 +166,32 @@ CAMLexport value callbackN_exn(value closure, int narg, value args[]) /* Exception-propagating variants of the above */ -CAMLexport value callback (value closure, value arg) +CAMLexport value caml_callback (value closure, value arg) { - value res = callback_exn(closure, arg); - if (Is_exception_result(res)) mlraise(Extract_exception(res)); + value res = caml_callback_exn(closure, arg); + if (Is_exception_result(res)) caml_raise(Extract_exception(res)); return res; } -CAMLexport value callback2 (value closure, value arg1, value arg2) +CAMLexport value caml_callback2 (value closure, value arg1, value arg2) { - value res = callback2_exn(closure, arg1, arg2); - if (Is_exception_result(res)) mlraise(Extract_exception(res)); + value res = caml_callback2_exn(closure, arg1, arg2); + if (Is_exception_result(res)) caml_raise(Extract_exception(res)); return res; } -CAMLexport value callback3 (value closure, value arg1, value arg2, value arg3) +CAMLexport value caml_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)); + value res = caml_callback3_exn(closure, arg1, arg2, arg3); + if (Is_exception_result(res)) caml_raise(Extract_exception(res)); return res; } -CAMLexport value callbackN (value closure, int narg, value args[]) +CAMLexport value caml_callbackN (value closure, int narg, value args[]) { - value res = callbackN_exn(closure, narg, args); - if (Is_exception_result(res)) mlraise(Extract_exception(res)); + value res = caml_callbackN_exn(closure, narg, args); + if (Is_exception_result(res)) caml_raise(Extract_exception(res)); return res; } @@ -183,19 +214,19 @@ static unsigned int hash_value_name(char *name) return h % Named_value_size; } -CAMLprim value register_named_value(value vname, value val) +CAMLprim value caml_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)); + caml_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); + caml_register_global_root(&nv->val); return Val_unit; } diff --git a/byterun/callback.h b/byterun/callback.h index 062d3287..ec03ed8e 100644 --- a/byterun/callback.h +++ b/byterun/callback.h @@ -11,37 +11,39 @@ /* */ /***********************************************************************/ -/* $Id: callback.h,v 1.8 2001/12/07 13:39:22 xleroy Exp $ */ +/* $Id: callback.h,v 1.13 2004/01/05 20:25:58 doligez Exp $ */ /* Callbacks from C to Caml */ -#ifndef _callback_ -#define _callback_ +#ifndef CAML_CALLBACK_H +#define CAML_CALLBACK_H +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif #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 caml_callback (value closure, value arg); +CAMLextern value caml_callback2 (value closure, value arg1, value arg2); +CAMLextern value caml_callback3 (value closure, value arg1, value arg2, + value arg3); +CAMLextern value caml_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[]); +CAMLextern value caml_callback_exn (value closure, value arg); +CAMLextern value caml_callback2_exn (value closure, value arg1, value arg2); +CAMLextern value caml_callback3_exn (value closure, + value arg1, value arg2, value arg3); +CAMLextern value caml_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; +CAMLextern int caml_callback_depth; #endif diff --git a/byterun/compact.c b/byterun/compact.c index 575d573c..fc94ba20 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compact.c,v 1.17 2002/12/12 18:59:11 doligez Exp $ */ +/* $Id: compact.c,v 1.22 2004/01/02 19:23:19 doligez Exp $ */ #include @@ -26,8 +26,8 @@ #include "roots.h" #include "weak.h" -extern unsigned long percent_free; /* major_gc.c */ -extern void shrink_heap (char *); /* memory.c */ +extern unsigned long caml_percent_free; /* major_gc.c */ +extern void caml_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.) @@ -42,7 +42,7 @@ extern void shrink_heap (char *); /* memory.c */ 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 (see [caml_register_global_roots] and [caml_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)) @@ -116,12 +116,12 @@ static char *compact_fl; static void init_compact_allocate (void) { - char *ch = heap_start; + char *ch = caml_heap_start; while (ch != NULL){ Chunk_alloc (ch) = 0; ch = Chunk_next (ch); } - compact_fl = heap_start; + compact_fl = caml_heap_start; } static char *compact_allocate (mlsize_t size) @@ -144,19 +144,19 @@ static char *compact_allocate (mlsize_t size) return adr; } -void compact_heap (void) +void caml_compact_heap (void) { char *ch, *chend; - Assert (gc_phase == Phase_idle); - gc_message (0x10, "Compacting heap...\n", 0); + Assert (caml_gc_phase == Phase_idle); + caml_gc_message (0x10, "Compacting heap...\n", 0); #ifdef DEBUG - heap_check (); + caml_heap_check (); #endif /* First pass: encode all noninfix headers. */ { - ch = heap_start; + ch = caml_heap_start; while (ch != NULL){ header_t *p = (header_t *) ch; @@ -186,10 +186,10 @@ void compact_heap (void) /* 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); + caml_do_roots (invert_root); + caml_final_do_weak_roots (invert_root); - ch = heap_start; + ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; chend = ch + Chunk_size (ch); @@ -222,7 +222,7 @@ void compact_heap (void) } /* Invert weak pointers. */ { - value *pp = &weak_list_head; + value *pp = &caml_weak_list_head; value p; word q; size_t sz, i; @@ -234,7 +234,9 @@ void compact_heap (void) 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))); + if (Field (p,i) != caml_weak_none){ + invert_pointer_at ((word *) &(Field (p,i))); + } } invert_pointer_at ((word *) pp); pp = &Field (p, 0); @@ -247,7 +249,7 @@ void compact_heap (void) Rebuild infix headers. */ { init_compact_allocate (); - ch = heap_start; + ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; @@ -302,7 +304,7 @@ void compact_heap (void) } p += sz; }else{ Assert (Ecolor (q) == 3); - /* This is guaranteed only if compact_heap was called after a + /* This is guaranteed only if caml_compact_heap was called after a nonincremental major GC: Assert (Tag_ehd (q) == String_tag); */ /* No pointers to the header and no infix header: @@ -320,7 +322,7 @@ void compact_heap (void) Use the exact same allocation algorithm as pass 3. */ { init_compact_allocate (); - ch = heap_start; + ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; @@ -348,7 +350,7 @@ void compact_heap (void) asize_t free = 0; asize_t wanted; - ch = heap_start; + ch = caml_heap_start; while (ch != NULL){ if (Chunk_alloc (ch) != 0){ live += Wsize_bsize (Chunk_alloc (ch)); @@ -359,8 +361,8 @@ void compact_heap (void) /* Add up the empty chunks until there are enough, then remove the other empty chunks. */ - wanted = percent_free * (live / 100 + 1); - ch = heap_start; + wanted = caml_percent_free * (live / 100 + 1); + ch = caml_heap_start; while (ch != NULL){ char *next_chunk = Chunk_next (ch); /* Chunk_next (ch) will be erased */ @@ -368,7 +370,7 @@ void compact_heap (void) if (free < wanted){ free += Wsize_bsize (Chunk_size (ch)); }else{ - shrink_heap (ch); + caml_shrink_heap (ch); } } ch = next_chunk; @@ -377,57 +379,58 @@ void compact_heap (void) /* Rebuild the free list. */ { - ch = heap_start; - fl_reset (); + ch = caml_heap_start; + caml_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); + caml_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); + ++ caml_stat_compactions; + caml_gc_message (0x10, "done.\n", 0); } -unsigned long percent_max; +unsigned long caml_percent_max; /* used in gc_ctrl.c */ -void compact_heap_maybe (void) +void caml_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 + FW = fl_size_at_change + 3 * (caml_fl_cur_size + - caml_fl_size_at_phase_change) + FW = 3 * caml_fl_cur_size - 2 * caml_fl_size_at_phase_change + Estimated live words: LW = caml_stat_heap_size - FW Estimated free percentage: FP = 100 * FW / LW - We compact the heap if FP > percent_max + We compact the heap if FP > caml_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; + Assert (caml_gc_phase == Phase_idle); + if (caml_percent_max >= 1000000) return; + if (caml_stat_major_collections < 5 || caml_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; + fw = 3.0 * caml_fl_cur_size - 2.0 * caml_fl_size_at_phase_change; + if (fw < 0) fw = caml_fl_cur_size; - if (fw >= Wsize_bsize (stat_heap_size)){ + if (fw >= Wsize_bsize (caml_stat_heap_size)){ fp = 1000000.0; }else{ - fp = 100.0 * fw / (Wsize_bsize (stat_heap_size) - fw); + fp = 100.0 * fw / (Wsize_bsize (caml_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 (); + caml_gc_message (0x200, "FL size at phase change = %lu\n", + (unsigned long) caml_fl_size_at_phase_change); + caml_gc_message (0x200, "Estimated overhead = %lu%%\n", (unsigned long) fp); + if (fp >= caml_percent_max){ + caml_gc_message (0x200, "Automatic compaction triggered.\n", 0); + caml_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); + fw = caml_fl_cur_size; + fp = 100.0 * fw / (Wsize_bsize (caml_stat_heap_size) - fw); + caml_gc_message (0x200, "Measured overhead: %lu%%\n", (unsigned long) fp); - compact_heap (); + caml_compact_heap (); } } diff --git a/byterun/compact.h b/byterun/compact.h index 60a66e52..424fe3e6 100644 --- a/byterun/compact.h +++ b/byterun/compact.h @@ -11,17 +11,17 @@ /* */ /***********************************************************************/ -/* $Id: compact.h,v 1.5 2001/12/07 13:39:23 xleroy Exp $ */ +/* $Id: compact.h,v 1.7 2003/12/31 14:20:35 doligez Exp $ */ -#ifndef _compact_ -#define _compact_ +#ifndef CAML_COMPACT_H +#define CAML_COMPACT_H #include "config.h" #include "misc.h" -extern void compact_heap (void); -extern void compact_heap_maybe (void); +extern void caml_compact_heap (void); +extern void caml_compact_heap_maybe (void); -#endif /* _compact_ */ +#endif /* CAML_COMPACT_H */ diff --git a/byterun/compare.c b/byterun/compare.c index b7fb30d5..7e89cea9 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compare.c,v 1.27 2003/07/16 17:28:00 doligez Exp $ */ +/* $Id: compare.c,v 1.31.6.1 2004/07/07 16:48:46 xleroy Exp $ */ #include #include @@ -34,11 +34,13 @@ static struct compare_item * compare_stack = compare_stack_init; static struct compare_item * compare_stack_limit = compare_stack_init + COMPARE_STACK_INIT_SIZE; +CAMLexport int caml_compare_unordered; + /* Free the compare stack if needed */ static void compare_free_stack(void) { if (compare_stack != compare_stack_init) { - stat_free(compare_stack); + free(compare_stack); /* Reinitialize the globals for next time around */ compare_stack = compare_stack_init; compare_stack_limit = compare_stack + COMPARE_STACK_INIT_SIZE; @@ -48,8 +50,9 @@ static void compare_free_stack(void) /* Same, then raise Out_of_memory */ static void compare_stack_overflow(void) { + caml_gc_message (0x04, "Stack overflow in structural comparison\n", 0); compare_free_stack(); - raise_out_of_memory(); + caml_raise_out_of_memory(); } /* Grow the compare stack */ @@ -77,23 +80,36 @@ static struct compare_item * compare_resize_stack(struct compare_item * sp) /* Structural comparison */ -static long compare_val(value v1, value v2) +#define LESS -1 +#define EQUAL 0 +#define GREATER 1 +#define UNORDERED (1L << (8 * sizeof(value) - 1)) + +/* The return value of compare_val is as follows: + > 0 v1 is greater than v2 + 0 v1 is equal to v2 + < 0 and > UNORDERED v1 is less than v2 + UNORDERED v1 and v2 cannot be compared */ + +static long compare_val(value v1, value v2, int total) { struct compare_item * sp; tag_t t1, t2; sp = compare_stack; while (1) { - if (v1 == v2) goto next_item; + if (v1 == v2 && total) goto next_item; if (Is_long(v1)) { + if (v1 == v2) goto next_item; if (Is_long(v2)) return Long_val(v1) - Long_val(v2); + /* Subtraction above cannot overflow and cannot result in UNORDERED */ 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 */ + return LESS; /* v1 long < v2 block */ } if (Is_long(v2)) { if ((Is_atom(v1) || Is_young(v1) || Is_in_heap(v1)) && @@ -101,14 +117,17 @@ static long compare_val(value v1, value v2) v1 = Forward_val(v1); continue; } - return 1; /* v1 block > v2 long */ + return GREATER; /* 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))) + (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap(v2))) { + if (v1 == v2) goto next_item; return (v1 >> 1) - (v2 >> 1); + /* Subtraction above cannot result in UNORDERED */ + } t1 = Tag_val(v1); t2 = Tag_val(v2); if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; } @@ -118,8 +137,9 @@ static long compare_val(value v1, value v2) case String_tag: { mlsize_t len1, len2, len; unsigned char * p1, * p2; - len1 = string_length(v1); - len2 = string_length(v2); + if (v1 == v2) break; + len1 = caml_string_length(v1); + len2 = caml_string_length(v2); for (len = (len1 <= len2 ? len1 : len2), p1 = (unsigned char *) String_val(v1), p2 = (unsigned char *) String_val(v2); @@ -132,8 +152,16 @@ static long compare_val(value v1, value v2) case Double_tag: { double d1 = Double_val(v1); double d2 = Double_val(v2); - if (d1 < d2) return -1; - if (d1 > d2) return 1; + if (d1 < d2) return LESS; + if (d1 > d2) return GREATER; + if (d1 != d2) { + if (! total) return UNORDERED; + /* One or both of d1 and d2 is NaN. Order according to the + convention NaN = NaN and NaN < f for all other floats f. */ + if (d1 == d1) return GREATER; /* d1 is not NaN, d2 is NaN */ + if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */ + /* d1 and d2 are both NaN, thus equal: continue comparison */ + } break; } case Double_array_tag: { @@ -144,18 +172,24 @@ static long compare_val(value v1, value v2) 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; + if (d1 < d2) return LESS; + if (d1 > d2) return GREATER; + if (d1 != d2) { + if (! total) return UNORDERED; + /* See comment for Double_tag case */ + if (d1 == d1) return GREATER; + if (d2 == d2) return LESS; + } } break; } case Abstract_tag: compare_free_stack(); - invalid_argument("equal: abstract value"); + caml_invalid_argument("equal: abstract value"); case Closure_tag: case Infix_tag: compare_free_stack(); - invalid_argument("equal: functional value"); + caml_invalid_argument("equal: functional value"); case Object_tag: { long oid1 = Oid_val(v1); long oid2 = Oid_val(v2); @@ -165,8 +199,10 @@ static long compare_val(value v1, value v2) case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare; - if (compare == NULL) invalid_argument("equal: abstract value"); + if (compare == NULL) caml_invalid_argument("equal: abstract value"); + caml_compare_unordered = 0; res = Custom_ops_val(v1)->compare(v1, v2); + if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; break; } @@ -192,64 +228,64 @@ static long compare_val(value v1, value v2) } 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 == compare_stack) return EQUAL; /* we're done */ + v1 = *((sp->v1)++); + v2 = *((sp->v2)++); if (--(sp->count) == 0) sp--; } } -CAMLprim value compare(value v1, value v2) +CAMLprim value caml_compare(value v1, value v2) { - long res = compare_val(v1, v2); + long res = compare_val(v1, v2, 1); /* Free stack if needed */ if (compare_stack != compare_stack_init) compare_free_stack(); - if (res < 0) - return Val_int(-1); + if (res < 0) + return Val_int(LESS); else if (res > 0) - return Val_int(1); + return Val_int(GREATER); else - return Val_int(0); + return Val_int(EQUAL); } -CAMLprim value equal(value v1, value v2) +CAMLprim value caml_equal(value v1, value v2) { - long res = compare_val(v1, v2); + long res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); return Val_int(res == 0); } -CAMLprim value notequal(value v1, value v2) +CAMLprim value caml_notequal(value v1, value v2) { - long res = compare_val(v1, v2); + long res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); return Val_int(res != 0); } -CAMLprim value lessthan(value v1, value v2) +CAMLprim value caml_lessthan(value v1, value v2) { - long res = compare_val(v1, v2); + long res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); - return Val_int(res < 0); + return Val_int(res - 1 < -1); } -CAMLprim value lessequal(value v1, value v2) +CAMLprim value caml_lessequal(value v1, value v2) { - long res = compare_val(v1, v2); + long res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); - return Val_int(res <= 0); + return Val_int(res - 1 <= -1); } -CAMLprim value greaterthan(value v1, value v2) +CAMLprim value caml_greaterthan(value v1, value v2) { - long res = compare_val(v1, v2); + long res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); return Val_int(res > 0); } -CAMLprim value greaterequal(value v1, value v2) +CAMLprim value caml_greaterequal(value v1, value v2) { - long res = compare_val(v1, v2); + long res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); return Val_int(res >= 0); } diff --git a/byterun/macintosh.h b/byterun/compare.h similarity index 71% rename from byterun/macintosh.h rename to byterun/compare.h index 5266f688..5f29b1f9 100644 --- a/byterun/macintosh.h +++ b/byterun/compare.h @@ -2,18 +2,20 @@ /* */ /* Objective Caml */ /* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* Damien Doligez, Projet Moscova, INRIA Rocquencourt */ /* */ -/* Copyright 1999 Institut National de Recherche en Informatique et */ +/* 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: macintosh.h,v 1.2 2001/12/07 13:39:31 xleroy Exp $ */ +/* $Id: compare.h,v 1.2 2003/12/31 14:20:35 doligez Exp $ */ -/* MacOS-specific stuff */ +#ifndef CAML_COMPARE_H +#define CAML_COMPARE_H -#define WIFEXITED(x) 1 -#define WEXITSTATUS(x) (x) +CAMLextern int caml_compare_unordered; + +#endif /* CAML_COMPARE_H */ diff --git a/byterun/compatibility.h b/byterun/compatibility.h new file mode 100644 index 00000000..71b46cf4 --- /dev/null +++ b/byterun/compatibility.h @@ -0,0 +1,309 @@ +/***********************************************************************/ +/* */ +/* 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 GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: compatibility.h,v 1.13 2004/06/14 14:28:30 doligez Exp $ */ + +/* definitions for compatibility with old identifiers */ + +#ifndef CAML_COMPATIBILITY_H +#define CAML_COMPATIBILITY_H + +#ifndef CAML_NAME_SPACE + +/* + #define --> CAMLextern (defined with CAMLexport or CAMLprim) + (rien) --> CAMLprim + g --> global C identifier + x --> special case + + SP* signals the special cases: + - when the identifier was not simply prefixed with [caml_] + - when the [caml_] version was already used for something else, and + was renamed out of the way (watch out for [caml_alloc] and + [caml_array_bound_error] in *.s) +*/ + +/* a faire: + - ui_* (reverifier que win32.c n'en depend pas) +*/ + + +/* **** alloc.c */ +#define alloc caml_alloc /*SP*/ +#define alloc_small caml_alloc_small +#define alloc_tuple caml_alloc_tuple +#define alloc_string caml_alloc_string +#define alloc_final caml_alloc_final +#define copy_string caml_copy_string +#define alloc_array caml_alloc_array +#define copy_string_array caml_copy_string_array +#define convert_flag_list caml_convert_flag_list + +/* **** array.c */ + +/* **** backtrace.c */ +#define backtrace_active caml_backtrace_active +#define backtrace_pos caml_backtrace_pos +#define backtrace_buffer caml_backtrace_buffer +#define backtrace_last_exn caml_backtrace_last_exn +#define print_exception_backtrace caml_print_exception_backtrace + +/* **** callback.c */ +#define callback_depth caml_callback_depth +#define callbackN_exn caml_callbackN_exn +#define callback_exn caml_callback_exn +#define callback2_exn caml_callback2_exn +#define callback3_exn caml_callback3_exn +#define callback caml_callback +#define callback2 caml_callback2 +#define callback3 caml_callback3 +#define callbackN caml_callbackN + +/* **** compact.c */ + +/* **** compare.c */ +#define compare_unordered caml_compare_unordered + +/* **** custom.c */ +#define alloc_custom caml_alloc_custom +#define register_custom_operations caml_register_custom_operations + +/* **** debugger.c */ + +/* **** dynlink.c */ + +/* **** extern.c */ +#define output_val caml_output_val +#define output_value_to_malloc caml_output_value_to_malloc +#define output_value_to_block caml_output_value_to_block +#define serialize_int_1 caml_serialize_int_1 +#define serialize_int_2 caml_serialize_int_2 +#define serialize_int_4 caml_serialize_int_4 +#define serialize_int_8 caml_serialize_int_8 +#define serialize_float_4 caml_serialize_float_4 +#define serialize_float_8 caml_serialize_float_8 +#define serialize_block_1 caml_serialize_block_1 +#define serialize_block_2 caml_serialize_block_2 +#define serialize_block_4 caml_serialize_block_4 +#define serialize_block_8 caml_serialize_block_8 +#define serialize_block_float_8 caml_serialize_block_float_8 + +/* **** fail.c */ +#define external_raise caml_external_raise +#define mlraise caml_raise /*SP*/ +#define raise_constant caml_raise_constant +#define raise_with_arg caml_raise_with_arg +#define raise_with_string caml_raise_with_string +#define failwith caml_failwith +#define invalid_argument caml_invalid_argument +#define array_bound_error caml_array_bound_error /*SP*/ +#define raise_out_of_memory caml_raise_out_of_memory +#define raise_stack_overflow caml_raise_stack_overflow +#define raise_sys_error caml_raise_sys_error +#define raise_end_of_file caml_raise_end_of_file +#define raise_zero_divide caml_raise_zero_divide +#define raise_not_found caml_raise_not_found +#define raise_sys_blocked_io caml_raise_sys_blocked_io +#define init_exceptions caml_init_exceptions +/* **** asmrun/fail.c */ +/* **** asmrun/.s */ + +/* **** finalise.c */ + +/* **** fix_code.c */ + +/* **** floats.c */ +/*#define Double_val caml_Double_val done in mlvalues.h as needed */ +/*#define Store_double_val caml_Store_double_val done in mlvalues.h as needed */ +#define copy_double caml_copy_double + +/* **** freelist.c */ + +/* **** gc_ctrl.c */ + +/* **** globroots.c */ +#define register_global_root caml_register_global_root +#define remove_global_root caml_remove_global_root + +/* **** hash.c */ +#define hash_variant caml_hash_variant + +/* **** instrtrace.c */ + +/* **** intern.c */ +#define input_val caml_input_val +#define input_val_from_string caml_input_val_from_string +#define input_value_from_malloc caml_input_value_from_malloc +#define input_value_from_block caml_input_value_from_block +#define deserialize_uint_1 caml_deserialize_uint_1 +#define deserialize_sint_1 caml_deserialize_sint_1 +#define deserialize_uint_2 caml_deserialize_uint_2 +#define deserialize_sint_2 caml_deserialize_sint_2 +#define deserialize_uint_4 caml_deserialize_uint_4 +#define deserialize_sint_4 caml_deserialize_sint_4 +#define deserialize_uint_8 caml_deserialize_uint_8 +#define deserialize_sint_8 caml_deserialize_sint_8 +#define deserialize_float_4 caml_deserialize_float_4 +#define deserialize_float_8 caml_deserialize_float_8 +#define deserialize_block_1 caml_deserialize_block_1 +#define deserialize_block_2 caml_deserialize_block_2 +#define deserialize_block_4 caml_deserialize_block_4 +#define deserialize_block_8 caml_deserialize_block_8 +#define deserialize_block_float_8 caml_deserialize_block_float_8 +#define deserialize_error caml_deserialize_error + +/* **** interp.c */ + +/* **** ints.c */ +#define int32_ops caml_int32_ops +#define copy_int32 caml_copy_int32 +/*#define Int64_val caml_Int64_val *** done in mlvalues.h as needed */ +#define int64_ops caml_int64_ops +#define copy_int64 caml_copy_int64 +#define nativeint_ops caml_nativeint_ops +#define copy_nativeint caml_copy_nativeint + +/* **** io.c */ +#define channel_mutex_free caml_channel_mutex_free +#define channel_mutex_lock caml_channel_mutex_lock +#define channel_mutex_unlock caml_channel_mutex_unlock +#define channel_mutex_unlock_exn caml_channel_mutex_unlock_exn +#define all_opened_channels caml_all_opened_channels +#define open_descriptor_in caml_open_descriptor_in /*SP*/ +#define open_descriptor_out caml_open_descriptor_out /*SP*/ +#define close_channel caml_close_channel /*SP*/ +#define channel_size caml_channel_size /*SP*/ +#define channel_binary_mode caml_channel_binary_mode +#define flush_partial caml_flush_partial /*SP*/ +#define flush caml_flush /*SP*/ +#define putword caml_putword +#define putblock caml_putblock +#define really_putblock caml_really_putblock +#define seek_out caml_seek_out /*SP*/ +#define pos_out caml_pos_out /*SP*/ +#define do_read caml_do_read +#define refill caml_refill +#define getword caml_getword +#define getblock caml_getblock +#define really_getblock caml_really_getblock +#define seek_in caml_seek_in /*SP*/ +#define pos_in caml_pos_in /*SP*/ +#define input_scan_line caml_input_scan_line /*SP*/ +#define finalize_channel caml_finalize_channel +#define alloc_channel caml_alloc_channel +/*#define Val_file_offset caml_Val_file_offset *** done in io.h as needed */ +/*#define File_offset_val caml_File_offset_val *** done in io.h as needed */ + +/* **** lexing.c */ + +/* **** main.c */ +/* *** no change */ + +/* **** major_gc.c */ +#define heap_start caml_heap_start +#define heap_end caml_heap_end +#define page_table caml_page_table + +/* **** md5.c */ +#define md5_string caml_md5_string +#define md5_chan caml_md5_chan +#define MD5Init caml_MD5Init +#define MD5Update caml_MD5Update +#define MD5Final caml_MD5Final +#define MD5Transform caml_MD5Transform + +/* **** memory.c */ +#define alloc_shr caml_alloc_shr +#define initialize caml_initialize +#define modify caml_modify +#define stat_alloc caml_stat_alloc +#define stat_free caml_stat_free +#define stat_resize caml_stat_resize + +/* **** meta.c */ + +/* **** minor_gc.c */ +#define young_start caml_young_start +#define young_end caml_young_end +#define young_ptr caml_young_ptr +#define young_limit caml_young_limit +#define ref_table_ptr caml_ref_table_ptr +#define ref_table_limit caml_ref_table_limit +#define minor_collection caml_minor_collection +#define check_urgent_gc caml_check_urgent_gc + +/* **** misc.c */ + +/* **** obj.c */ + +/* **** parsing.c */ + +/* **** prims.c */ + +/* **** printexc.c */ +#define format_caml_exception caml_format_exception /*SP*/ + +/* **** roots.c */ +#define local_roots caml_local_roots +#define scan_roots_hook caml_scan_roots_hook +#define do_local_roots caml_do_local_roots + +/* **** signals.c */ +#define async_signal_mode caml_async_signal_mode +#define pending_signal caml_pending_signal +#define something_to_do caml_something_to_do +#define enter_blocking_section_hook caml_enter_blocking_section_hook +#define leave_blocking_section_hook caml_leave_blocking_section_hook +#define async_action_hook caml_async_action_hook +#define enter_blocking_section caml_enter_blocking_section +#define leave_blocking_section caml_leave_blocking_section +#define convert_signal_number caml_convert_signal_number +/* **** asmrun/signals.c */ +#define garbage_collection caml_garbage_collection + +/* **** stacks.c */ +#define stack_low caml_stack_low +#define stack_high caml_stack_high +#define stack_threshold caml_stack_threshold +#define extern_sp caml_extern_sp +#define trapsp caml_trapsp +#define trap_barrier caml_trap_barrier + +/* **** startup.c */ +#define atom_table caml_atom_table +/* **** asmrun/startup.c */ +#define static_data_start caml_static_data_start +#define static_data_end caml_static_data_end + +/* **** str.c */ +#define string_length caml_string_length + +/* **** sys.c */ +#define sys_error caml_sys_error +#define sys_exit caml_sys_exit + +/* **** terminfo.c */ + +/* **** unix.c & win32.c */ +#define search_exe_in_path caml_search_exe_in_path + +/* **** weak.c */ + +/* **** asmcomp/asmlink.ml */ + +/* **** asmcomp/cmmgen.ml */ + +/* **** asmcomp/asmlink.ml, asmcomp/cmmgen.ml, asmcomp/compilenv.ml */ + +#endif /* CAML_NAME_SPACE */ +#endif /* CAML_COMPATIBILITY_H */ diff --git a/byterun/config.h b/byterun/config.h index 1caa7ea1..46a787b4 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -11,23 +11,22 @@ /* */ /***********************************************************************/ -/* $Id: config.h,v 1.32 2002/12/15 23:27:06 doligez Exp $ */ +/* $Id: config.h,v 1.36 2004/04/19 07:55:28 starynke Exp $ */ -#ifndef _config_ -#define _config_ +#ifndef CAML_CONFIG_H +#define CAML_CONFIG_H /* */ /* */ /* */ -#if !macintosh #include "../config/m.h" #include "../config/s.h" -#else -#include -#include -#endif /* */ +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif + /* Types for signed chars, 16-bit integers, 32-bit integers, 64-bit integers */ typedef signed char schar; @@ -75,7 +74,7 @@ typedef struct { uint32 l, h; } uint64, int64; /* 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) +#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) && !defined (SHRINKED_GNUC) && !defined(CAML_JIT) #define THREADED_CODE #endif @@ -143,4 +142,4 @@ typedef struct { uint32 l, h; } uint64, int64; #define Max_percent_free_def 500 -#endif /* _config_ */ +#endif /* CAML_CONFIG_H */ diff --git a/byterun/custom.c b/byterun/custom.c index 135e6684..7e43154c 100644 --- a/byterun/custom.c +++ b/byterun/custom.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: custom.c,v 1.10 2002/06/07 09:49:36 xleroy Exp $ */ +/* $Id: custom.c,v 1.14 2004/01/05 20:25:58 doligez Exp $ */ #include @@ -21,23 +21,23 @@ #include "memory.h" #include "mlvalues.h" -CAMLextern value alloc_custom(struct custom_operations * ops, - unsigned long size, - mlsize_t mem, - mlsize_t max) +CAMLexport value caml_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); + result = caml_alloc_small(wosize, Custom_tag); Custom_ops_val(result) = ops; } else { - result = alloc_shr(wosize, Custom_tag); + result = caml_alloc_shr(wosize, Custom_tag); Custom_ops_val(result) = ops; - adjust_gc_speed(mem, max); - result = check_urgent_gc(result); + caml_adjust_gc_speed(mem, max); + result = caml_check_urgent_gc(result); } return result; } @@ -49,10 +49,10 @@ struct custom_operations_list { static struct custom_operations_list * custom_ops_table = NULL; -CAMLextern void register_custom_operations(struct custom_operations * ops) +CAMLexport void caml_register_custom_operations(struct custom_operations * ops) { struct custom_operations_list * l = - stat_alloc(sizeof(struct custom_operations_list)); + caml_stat_alloc(sizeof(struct custom_operations_list)); Assert(ops->identifier != NULL); Assert(ops->deserialize != NULL); l->ops = ops; @@ -60,7 +60,7 @@ CAMLextern void register_custom_operations(struct custom_operations * ops) custom_ops_table = l; } -struct custom_operations * find_custom_operations(char * ident) +struct custom_operations * caml_find_custom_operations(char * ident) { struct custom_operations_list * l; for (l = custom_ops_table; l != NULL; l = l->next) @@ -70,31 +70,33 @@ struct custom_operations * find_custom_operations(char * ident) static struct custom_operations_list * custom_ops_final_table = NULL; -struct custom_operations * final_custom_operations(final_fun fn) +struct custom_operations * caml_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 = caml_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 = caml_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; +extern struct custom_operations caml_int32_ops, + caml_nativeint_ops, + caml_int64_ops; -void init_custom_operations(void) +void caml_init_custom_operations(void) { - register_custom_operations(&int32_ops); - register_custom_operations(&nativeint_ops); - register_custom_operations(&int64_ops); + caml_register_custom_operations(&caml_int32_ops); + caml_register_custom_operations(&caml_nativeint_ops); + caml_register_custom_operations(&caml_int64_ops); } diff --git a/byterun/custom.h b/byterun/custom.h index 83267cc9..7240b0a0 100644 --- a/byterun/custom.h +++ b/byterun/custom.h @@ -11,12 +11,15 @@ /* */ /***********************************************************************/ -/* $Id: custom.h,v 1.8 2002/06/07 09:49:37 xleroy Exp $ */ +/* $Id: custom.h,v 1.11 2004/01/01 16:42:35 doligez Exp $ */ -#ifndef _custom_ -#define _custom_ +#ifndef CAML_CUSTOM_H +#define CAML_CUSTOM_H +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif #include "mlvalues.h" struct custom_operations { @@ -38,18 +41,19 @@ struct custom_operations { #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 value caml_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); +CAMLextern void caml_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 struct custom_operations * caml_find_custom_operations(char * ident); +extern struct custom_operations * + caml_final_custom_operations(void (*fn)(value)); -extern void init_custom_operations(void); +extern void caml_init_custom_operations(void); /* */ -#endif +#endif /* CAML_CUSTOM_H */ diff --git a/byterun/debugger.c b/byterun/debugger.c index 15a2ba9d..adb74b25 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: debugger.c,v 1.24 2002/10/22 12:30:03 doligez Exp $ */ +/* $Id: debugger.c,v 1.28 2004/01/02 19:23:20 doligez Exp $ */ /* Interface with the debugger */ @@ -29,16 +29,16 @@ #include "stacks.h" #include "sys.h" -int debugger_in_use = 0; -unsigned long event_count; +int caml_debugger_in_use = 0; +unsigned long caml_event_count; #if !defined(HAS_SOCKETS) || defined(_WIN32) -void debugger_init(void) +void caml_debugger_init(void) { } -void debugger(enum event_kind event) +void caml_debugger(enum event_kind event) { } @@ -72,22 +72,22 @@ 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); + caml_fatal_error("cannot connect to debugger"); + dbg_in = caml_open_descriptor_in(dbg_socket); + dbg_out = caml_open_descriptor_out(dbg_socket); + if (!caml_debugger_in_use) caml_putword(dbg_out, -1); /* first connection */ + caml_putword(dbg_out, getpid()); + caml_flush(dbg_out); } static void close_connection(void) { - close_channel(dbg_in); - close_channel(dbg_out); - dbg_socket = -1; /* was closed by close_channel */ + caml_close_channel(dbg_in); + caml_close_channel(dbg_out); + dbg_socket = -1; /* was closed by caml_close_channel */ } -void debugger_init(void) +void caml_debugger_init(void) { char * address; char * port, * p; @@ -121,44 +121,44 @@ void debugger_init(void) 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); + caml_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; + caml_debugger_in_use = 1; + caml_trap_barrier = caml_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 */ + if (caml_really_getblock(chan, (char *) &res, sizeof(res)) == 0) + caml_raise_end_of_file(); /* Bad, but consistent with caml_getword */ return res; } static void putval(struct channel *chan, value val) { - really_putblock(chan, (char *) &val, sizeof(val)); + caml_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; + /* Catch exceptions raised by [caml_output_val] */ + saved_external_raise = caml_external_raise; if (sigsetjmp(raise_buf.buf, 0) == 0) { - external_raise = &raise_buf; - output_val(chan, val, Val_unit); + caml_external_raise = &raise_buf; + caml_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); + /* Send wrong magic number, will cause [caml_input_value] to fail */ + caml_really_putblock(chan, "\000\000\000\000", 4); } - external_raise = saved_external_raise; + caml_external_raise = saved_external_raise; } #define Pc(sp) ((code_t)((sp)[0])) @@ -166,7 +166,7 @@ static void safe_output_value(struct channel *chan, value val) #define Extra_args(sp) (Long_val(((sp)[2]))) #define Locals(sp) ((sp) + 3) -void debugger(enum event_kind event) +void caml_debugger(enum event_kind event) { int frame_number; value * frame; @@ -177,7 +177,7 @@ void debugger(enum event_kind event) /* Reset current frame */ frame_number = 0; - frame = extern_sp + 1; + frame = caml_extern_sp + 1; /* Report the event to the debugger */ switch(event) { @@ -199,16 +199,16 @@ void debugger(enum event_kind event) putch(dbg_out, REP_UNCAUGHT_EXC); break; } - putword(dbg_out, event_count); + caml_putword(dbg_out, caml_event_count); if (event == EVENT_COUNT || event == BREAKPOINT) { - putword(dbg_out, stack_high - frame); - putword(dbg_out, (Pc(frame) - start_code) * sizeof(opcode_t)); + caml_putword(dbg_out, caml_stack_high - frame); + caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t)); } else { /* No PC and no stack frame associated with other events */ - putword(dbg_out, 0); - putword(dbg_out, 0); + caml_putword(dbg_out, 0); + caml_putword(dbg_out, 0); } - flush(dbg_out); + caml_flush(dbg_out); command_loop: @@ -216,23 +216,23 @@ void debugger(enum event_kind event) while(1) { switch(getch(dbg_in)) { case REQ_SET_EVENT: - pos = getword(dbg_in); + pos = caml_getword(dbg_in); Assert (pos >= 0); - Assert (pos < code_size); - set_instruction(start_code + pos / sizeof(opcode_t), EVENT); + Assert (pos < caml_code_size); + caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), EVENT); break; case REQ_SET_BREAKPOINT: - pos = getword(dbg_in); + pos = caml_getword(dbg_in); Assert (pos >= 0); - Assert (pos < code_size); - set_instruction(start_code + pos / sizeof(opcode_t), BREAK); + Assert (pos < caml_code_size); + caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), BREAK); break; case REQ_RESET_INSTR: - pos = getword(dbg_in); + pos = caml_getword(dbg_in); Assert (pos >= 0); - Assert (pos < code_size); + Assert (pos < caml_code_size); pos = pos / sizeof(opcode_t); - set_instruction(start_code + pos, saved_code[pos]); + caml_set_instruction(caml_start_code + pos, caml_saved_code[pos]); break; case REQ_CHECKPOINT: i = fork(); @@ -240,12 +240,12 @@ void debugger(enum event_kind event) close_connection(); /* Close parent connection. */ open_connection(); /* Open new connection with debugger */ } else { - putword(dbg_out, i); - flush(dbg_out); + caml_putword(dbg_out, i); + caml_flush(dbg_out); } break; case REQ_GO: - event_count = getword(dbg_in); + caml_event_count = caml_getword(dbg_in); return; case REQ_STOP: exit(0); @@ -254,82 +254,82 @@ void debugger(enum event_kind event) wait(NULL); break; case REQ_INITIAL_FRAME: - frame = extern_sp + 1; + frame = caml_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)); + caml_putword(dbg_out, caml_stack_high - frame); + if (frame < caml_stack_high){ + caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t)); }else{ - putword (dbg_out, 0); + caml_putword (dbg_out, 0); } - flush(dbg_out); + caml_flush(dbg_out); break; case REQ_SET_FRAME: - i = getword(dbg_in); - frame = stack_high - i; + i = caml_getword(dbg_in); + frame = caml_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); + i = caml_getword(dbg_in); + if (frame + Extra_args(frame) + i + 3 >= caml_stack_high) { + caml_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)); + caml_putword(dbg_out, caml_stack_high - frame); + caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t)); } - flush(dbg_out); + caml_flush(dbg_out); break; case REQ_SET_TRAP_BARRIER: - i = getword(dbg_in); - trap_barrier = stack_high - i; + i = caml_getword(dbg_in); + caml_trap_barrier = caml_stack_high - i; break; case REQ_GET_LOCAL: - i = getword(dbg_in); + i = caml_getword(dbg_in); putval(dbg_out, Locals(frame)[i]); - flush(dbg_out); + caml_flush(dbg_out); break; case REQ_GET_ENVIRONMENT: - i = getword(dbg_in); + i = caml_getword(dbg_in); putval(dbg_out, Field(Env(frame), i)); - flush(dbg_out); + caml_flush(dbg_out); break; case REQ_GET_GLOBAL: - i = getword(dbg_in); - putval(dbg_out, Field(global_data, i)); - flush(dbg_out); + i = caml_getword(dbg_in); + putval(dbg_out, Field(caml_global_data, i)); + caml_flush(dbg_out); break; case REQ_GET_ACCU: - putval(dbg_out, *extern_sp); - flush(dbg_out); + putval(dbg_out, *caml_extern_sp); + caml_flush(dbg_out); break; case REQ_GET_HEADER: val = getval(dbg_in); - putword(dbg_out, Hd_val(val)); - flush(dbg_out); + caml_putword(dbg_out, Hd_val(val)); + caml_flush(dbg_out); break; case REQ_GET_FIELD: val = getval(dbg_in); - i = getword(dbg_in); + i = caml_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); + caml_really_putblock(dbg_out, (char *) &d, 8); } - flush(dbg_out); + caml_flush(dbg_out); break; case REQ_MARSHAL_OBJ: val = getval(dbg_in); safe_output_value(dbg_out, val); - flush(dbg_out); + caml_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); + caml_putword(dbg_out, (Code_val(val)-caml_start_code) * sizeof(opcode_t)); + caml_flush(dbg_out); break; } } diff --git a/byterun/debugger.h b/byterun/debugger.h index 754fd1f5..2dacb549 100644 --- a/byterun/debugger.h +++ b/byterun/debugger.h @@ -11,27 +11,27 @@ /* */ /***********************************************************************/ -/* $Id: debugger.h,v 1.7 2001/12/07 13:39:24 xleroy Exp $ */ +/* $Id: debugger.h,v 1.9 2004/01/01 16:42:35 doligez Exp $ */ /* Interface with the debugger */ -#ifndef _debugger_ -#define _debugger_ +#ifndef CAML_DEBUGGER_H +#define CAML_DEBUGGER_H #include "misc.h" #include "mlvalues.h" -extern int debugger_in_use; +extern int caml_debugger_in_use; extern int running; -extern unsigned long event_count; +extern unsigned long caml_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); +void caml_debugger_init (void); +void caml_debugger (enum event_kind event); /* Communication protocol */ @@ -83,7 +83,7 @@ enum debugger_request { /* 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. */ + format as [caml_output_value]. */ REQ_GET_CLOSURE_CODE = 'C' /* mlvalue v */ /* Send the code address of the given closure. Reply is one uint32. */ @@ -107,6 +107,4 @@ enum debugger_reply { /* Program exited due to a stray exception. */ }; -#endif - - +#endif /* CAML_DEBUGGER_H */ diff --git a/byterun/dynlink.c b/byterun/dynlink.c index f85f4252..cbbf5ea3 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -36,18 +36,18 @@ #ifndef NATIVE_CODE /* The table of primitives */ -struct ext_table prim_table; +struct ext_table caml_prim_table; #ifdef DEBUG /* The names of primitives (for instrtrace.c) */ -struct ext_table prim_name_table; +struct ext_table caml_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; +struct ext_table caml_shared_libs_path; /* Look up the given primitive name in the built-in primitive table, then in the opened shared libraries (shared_libs) */ @@ -56,9 +56,9 @@ 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; caml_names_of_builtin_cprim[i] != NULL; i++) { + if (strcmp(name, caml_names_of_builtin_cprim[i]) == 0) + return caml_builtin_cprim[i]; } for (i = 0; i < shared_libs.size; i++) { res = caml_dlsym(shared_libs.contents[i], name); @@ -81,34 +81,35 @@ static char * parse_ld_conf(void) 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)); + ldconfname = caml_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); + caml_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); + caml_fatal_error_arg("Fatal error: cannot read loader config file %s\n", + ldconfname); + config = caml_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); + caml_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); + caml_ext_table_add(&caml_shared_libs_path, q); q = p + 1; } } - if (q < p) ext_table_add(&shared_libs_path, q); + if (q < p) caml_ext_table_add(&caml_shared_libs_path, q); close(ldconf); - stat_free(ldconfname); + caml_stat_free(ldconfname); return config; } @@ -119,22 +120,23 @@ 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); + realname = caml_search_dll_in_path(&caml_shared_libs_path, name); + caml_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); + caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n", name, + "Reason: %s\n", caml_dlerror()); + caml_ext_table_add(&shared_libs, handle); + caml_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) +void caml_build_primitive_table(char * lib_path, + char * libs, + char * req_prims) { char * tofree1, * tofree2; char * p; @@ -144,90 +146,102 @@ void build_primitive_table(char * lib_path, - 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")); + tofree1 = caml_decompose_path(&caml_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); + caml_ext_table_add(&caml_shared_libs_path, p); tofree2 = parse_ld_conf(); /* Open the shared libraries */ - ext_table_init(&shared_libs, 8); + caml_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); + caml_ext_table_init(&caml_prim_table, 0x180); #ifdef DEBUG - ext_table_init(&prim_name_table, 0x180); + caml_ext_table_init(&caml_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); + caml_fatal_error_arg("Fatal error: unknown C primitive `%s'\n", p); + caml_ext_table_add(&caml_prim_table, (void *) prim); #ifdef DEBUG - ext_table_add(&prim_name_table, strdup(p)); + caml_ext_table_add(&caml_prim_name_table, strdup(p)); #endif } /* Clean up */ - stat_free(tofree1); - stat_free(tofree2); - ext_table_free(&shared_libs_path, 0); + caml_stat_free(tofree1); + caml_stat_free(tofree2); + caml_ext_table_free(&caml_shared_libs_path, 0); } -#endif +/* Build the table of primitives as a copy of the builtin primitive table. + Used for executables generated by ocamlc -output-obj. */ + +void caml_build_primitive_table_builtin(void) +{ + int i; + caml_ext_table_init(&caml_prim_table, 0x180); + for (i = 0; caml_builtin_cprim[i] != 0; i++) + caml_ext_table_add(&caml_prim_table, (void *) caml_builtin_cprim[i]); +} + +#endif /* NATIVE_CODE */ /** dlopen interface for the bytecode linker **/ #define Handle_val(v) (*((void **) (v))) -CAMLprim value dynlink_open_lib(value filename) +CAMLprim value caml_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); + if (handle == NULL) caml_failwith(caml_dlerror()); + result = caml_alloc_small(1, Abstract_tag); Handle_val(result) = handle; return result; } -CAMLprim value dynlink_close_lib(value handle) +CAMLprim value caml_dynlink_close_lib(value handle) { caml_dlclose(Handle_val(handle)); return Val_unit; } -#include -CAMLprim value dynlink_lookup_symbol(value handle, value symbolname) +/*#include */ +CAMLprim value caml_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); + if (symb == NULL) return Val_unit /*caml_failwith(caml_dlerror())*/; + result = caml_alloc_small(1, Abstract_tag); Handle_val(result) = symb; return result; } #ifndef NATIVE_CODE -CAMLprim value dynlink_add_primitive(value handle) +CAMLprim value caml_dynlink_add_primitive(value handle) { - return Val_int(ext_table_add(&prim_table, Handle_val(handle))); + return Val_int(caml_ext_table_add(&caml_prim_table, Handle_val(handle))); } -CAMLprim value dynlink_get_current_libs(value unit) +CAMLprim value caml_dynlink_get_current_libs(value unit) { CAMLparam0(); CAMLlocal1(res); int i; - res = alloc_tuple(shared_libs.size); + res = caml_alloc_tuple(shared_libs.size); for (i = 0; i < shared_libs.size; i++) { - value v = alloc_small(1, Abstract_tag); + value v = caml_alloc_small(1, Abstract_tag); Handle_val(v) = shared_libs.contents[i]; Store_field(res, i, v); } @@ -236,16 +250,16 @@ CAMLprim value dynlink_get_current_libs(value unit) #else -value dynlink_add_primitive(value handle) +value caml_dynlink_add_primitive(value handle) { - invalid_argument("dynlink_add_primitive"); + caml_invalid_argument("dynlink_add_primitive"); return Val_unit; /* not reached */ } -value dynlink_get_current_libs(value unit) +value caml_dynlink_get_current_libs(value unit) { - invalid_argument("dynlink_get_current_libs"); + caml_invalid_argument("dynlink_get_current_libs"); return Val_unit; /* not reached */ } -#endif +#endif /* NATIVE_CODE */ diff --git a/byterun/dynlink.h b/byterun/dynlink.h index df0ce7df..ad4bfbad 100644 --- a/byterun/dynlink.h +++ b/byterun/dynlink.h @@ -15,8 +15,8 @@ /* Dynamic loading of C primitives. */ -#ifndef _dynlink_ -#define _dynlink_ +#ifndef CAML_DYNLINK_H +#define CAML_DYNLINK_H #include "misc.h" @@ -24,11 +24,15 @@ 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); +extern void caml_build_primitive_table(char * lib_path, + char * libs, + char * req_prims); /* The search path for shared libraries */ -extern struct ext_table shared_libs_path; +extern struct ext_table caml_shared_libs_path; -#endif +/* Build the table of primitives as a copy of the builtin primitive table. + Used for executables generated by ocamlc -output-obj. */ +extern void caml_build_primitive_table_builtin(void); + +#endif /* CAML_DYNLINK_H */ diff --git a/byterun/exec.h b/byterun/exec.h index d2b4a93e..ac788cd3 100644 --- a/byterun/exec.h +++ b/byterun/exec.h @@ -11,12 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: exec.h,v 1.12 2001/12/07 13:39:26 xleroy Exp $ */ +/* $Id: exec.h,v 1.14 2004/06/01 12:36:34 xleroy Exp $ */ /* exec.h : format of executable bytecode files */ -#ifndef _exec_ -#define _exec_ +#ifndef CAML_EXEC_H +#define CAML_EXEC_H /* Executable bytecode files are composed of a number of sections, identified by 4-character names. A table of contents at the @@ -56,7 +56,7 @@ struct exec_trailer { /* Magic number for this release */ -#define EXEC_MAGIC "Caml1999X007" +#define EXEC_MAGIC "Caml1999X008" -#endif +#endif /* CAML_EXEC_H */ diff --git a/byterun/extern.c b/byterun/extern.c index bc0a72c5..68c24367 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -11,10 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: extern.c,v 1.45 2003/06/19 13:05:17 xleroy Exp $ */ +/* $Id: extern.c,v 1.56 2004/06/19 16:02:07 xleroy Exp $ */ /* Structured output */ +/* The interface of this file is "intext.h" */ + #include #include "alloc.h" #include "custom.h" @@ -60,7 +62,7 @@ static void alloc_extern_table(void) { asize_t i; extern_table = (struct extern_obj *) - stat_alloc(extern_table_size * sizeof(struct extern_obj)); + caml_stat_alloc(extern_table_size * sizeof(struct extern_obj)); for (i = 0; i < extern_table_size; i++) extern_table[i].ofs = 0; } @@ -89,7 +91,7 @@ static void resize_extern_table(void) extern_table[h].obj = obj; } } - stat_free(oldtable); + caml_stat_free(oldtable); } /* Free the extern table. We keep it around for next call if @@ -99,7 +101,7 @@ static void free_extern_table(void) { if (extern_table_size > INITIAL_EXTERN_TABLE_SIZE || initial_ofs >= INITIAL_OFFSET_MAX) { - stat_free(extern_table); + caml_stat_free(extern_table); extern_table = NULL; } } @@ -111,7 +113,7 @@ static int extern_block_malloced; static void alloc_extern_block(void) { - extern_block = stat_alloc(INITIAL_EXTERN_BLOCK_SIZE); + extern_block = caml_stat_alloc(INITIAL_EXTERN_BLOCK_SIZE); extern_limit = extern_block + INITIAL_EXTERN_BLOCK_SIZE; extern_ptr = extern_block; extern_block_malloced = 1; @@ -124,13 +126,13 @@ static void resize_extern_block(int required) if (! extern_block_malloced) { initial_ofs += obj_counter; free_extern_table(); - failwith("Marshal.to_buffer: buffer overflow"); + caml_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_block = caml_stat_resize(extern_block, size); extern_limit = extern_block + size; extern_ptr = extern_block + curr_pos; } @@ -153,7 +155,7 @@ static void writeblock(char *data, long int len) writeblock((char *)(data), (ndoubles) * 8) #else #define writeblock_float8(data,ndoubles) \ - serialize_block_float_8((data), (ndoubles)) + caml_serialize_block_float_8((data), (ndoubles)) #endif static void writecode8(int code, long int val) @@ -214,10 +216,10 @@ 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); + if (extern_block_malloced) caml_stat_free(extern_block); initial_ofs += obj_counter; free_extern_table(); - invalid_argument(msg); + caml_invalid_argument(msg); } static void extern_rec(value v) @@ -246,8 +248,15 @@ static void extern_rec(value v) asize_t h; if (tag == Forward_tag) { - v = Forward_val (v); - goto tailcall; + value f = Forward_val (v); + if (Is_block (f) && (Is_young (f) || Is_in_heap (f)) + && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag + || Tag_val (f) == Double_tag)){ + /* Do not short-circuit the pointer. */ + }else{ + v = f; + goto tailcall; + } } /* Atoms are treated specially for two reasons: they are not allocated in the externed block, and they are automatically shared. */ @@ -285,7 +294,7 @@ static void extern_rec(value v) /* Output the contents of the object */ switch(tag) { case String_tag: { - mlsize_t len = string_length(v); + mlsize_t len = caml_string_length(v); if (len < 0x20) { Write(PREFIX_SMALL_STRING + len); } else if (len < 0x100) { @@ -323,15 +332,17 @@ static void extern_rec(value v) break; } case Abstract_tag: - extern_invalid_argument("output_value: abstract value"); + extern_invalid_argument("output_value: abstract value (Abstract)"); break; case Infix_tag: writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd)); extern_rec(v - Infix_offset_hd(hd)); break; + /* Use default case for objects 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; @@ -339,7 +350,7 @@ static void extern_rec(value v) unsigned long * wsize_64) = Custom_ops_val(v)->serialize; if (serialize == NULL) - extern_invalid_argument("output_value: abstract value"); + extern_invalid_argument("output_value: abstract value (Custom)"); Write(CODE_CUSTOM); writeblock(ident, strlen(ident) + 1); Custom_ops_val(v)->serialize(v, &sz_32, &sz_64); @@ -347,9 +358,6 @@ static void extern_rec(value v) size_64 += 2 + ((sz_64 + 7) >> 3); break; } - case Forward_tag: - Assert(0); - /*fallthrough*/ default: { mlsize_t i; if (tag < 16 && sz < 8) { @@ -370,14 +378,14 @@ static void extern_rec(value v) } return; } - if ((char *) v >= code_area_start && (char *) v < code_area_end) { + if ((char *) v >= caml_code_area_start && (char *) v < caml_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); + writecode32(CODE_CODEPOINTER, (char *) v - caml_code_area_start); + writeblock((char *) caml_code_checksum(), 16); return; } - extern_invalid_argument("output_value: abstract value"); + extern_invalid_argument("output_value: abstract value (outside heap)"); } enum { NO_SHARING = 1, CLOSURES = 2 }; @@ -388,7 +396,7 @@ static long extern_value(value v, value flags) long res_len; int fl; /* Parse flag list */ - fl = convert_flag_list(flags, extern_flags); + fl = caml_convert_flag_list(flags, extern_flags); extern_ignore_sharing = fl & NO_SHARING; extern_closures = fl & CLOSURES; /* Allocate hashtable of objects already seen, if needed */ @@ -421,7 +429,7 @@ static long extern_value(value v, value flags) /* 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"); + caml_failwith("output_value: object too big"); } #endif extern_ptr = extern_block + 4; @@ -433,48 +441,48 @@ static long extern_value(value v, value flags) return res_len; } -void output_val(struct channel *chan, value v, value flags) +void caml_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"); + if (! caml_channel_binary_mode(chan)) + caml_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. */ + /* During [caml_really_putblock], concurrent [caml_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); + caml_really_putblock(chan, extern_block, len); + caml_stat_free(block); } -CAMLprim value output_value(value vchan, value v, value flags) +CAMLprim value caml_output_value(value vchan, value v, value flags) { CAMLparam3 (vchan, v, flags); struct channel * channel = Channel(vchan); Lock(channel); - output_val(channel, v, flags); + caml_output_val(channel, v, flags); Unlock(channel); CAMLreturn (Val_unit); } -CAMLprim value output_value_to_string(value v, value flags) +CAMLprim value caml_output_value_to_string(value v, value flags) { long len; value res; alloc_extern_block(); len = extern_value(v, flags); - res = alloc_string(len); + res = caml_alloc_string(len); memmove(String_val(res), extern_block, len); - stat_free(extern_block); + caml_stat_free(extern_block); return res; } -CAMLprim value output_value_to_buffer(value buf, value ofs, value len, - value v, value flags) +CAMLprim value caml_output_value_to_buffer(value buf, value ofs, value len, + value v, value flags) { long len_res; extern_block = &Byte(buf, Long_val(ofs)); @@ -485,8 +493,9 @@ CAMLprim value output_value_to_buffer(value buf, value ofs, value len, return Val_long(len_res); } -CAMLexport void output_value_to_malloc(value v, value flags, - /*out*/ char ** buf, /*out*/ long * len) +CAMLexport void caml_output_value_to_malloc(value v, value flags, + /*out*/ char ** buf, + /*out*/ long * len) { long len_res; alloc_extern_block(); @@ -495,8 +504,8 @@ CAMLexport void output_value_to_malloc(value v, value flags, *len = len_res; } -CAMLexport long output_value_to_block(value v, value flags, - char * buf, long len) +CAMLexport long caml_output_value_to_block(value v, value flags, + char * buf, long len) { long len_res; extern_block = buf; @@ -509,14 +518,14 @@ CAMLexport long output_value_to_block(value v, value flags, /* Functions for writing user-defined marshallers */ -CAMLexport void serialize_int_1(int i) +CAMLexport void caml_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) +CAMLexport void caml_serialize_int_2(int i) { if (extern_ptr + 2 > extern_limit) resize_extern_block(2); extern_ptr[0] = i >> 8; @@ -524,7 +533,7 @@ CAMLexport void serialize_int_2(int i) extern_ptr += 2; } -CAMLexport void serialize_int_4(int32 i) +CAMLexport void caml_serialize_int_4(int32 i) { if (extern_ptr + 4 > extern_limit) resize_extern_block(4); extern_ptr[0] = i >> 24; @@ -534,90 +543,100 @@ CAMLexport void serialize_int_4(int32 i) extern_ptr += 4; } -CAMLexport void serialize_int_8(int64 i) +CAMLexport void caml_serialize_int_8(int64 i) { - serialize_block_8(&i, 1); + caml_serialize_block_8(&i, 1); } -CAMLexport void serialize_float_4(float f) +CAMLexport void caml_serialize_float_4(float f) { - serialize_block_4(&f, 1); + caml_serialize_block_4(&f, 1); } -CAMLexport void serialize_float_8(double f) +CAMLexport void caml_serialize_float_8(double f) { - serialize_block_8(&f, 1); + caml_serialize_block_8(&f, 1); } -CAMLexport void serialize_block_1(void * data, long len) +CAMLexport void caml_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) +CAMLexport void caml_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; + { + unsigned char * p; + char * q; + 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) +CAMLexport void caml_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; + { + unsigned char * p; + char * q; + 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) +CAMLexport void caml_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; + { + unsigned char * p; + char * q; + 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) +CAMLexport void caml_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; + { + unsigned char * p; + char * q; + 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; + { + unsigned char * p; + char * q; + 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 index 176ad8ca..ac45f856 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fail.c,v 1.22 2001/12/07 13:39:26 xleroy Exp $ */ +/* $Id: fail.c,v 1.29 2004/05/17 17:09:59 doligez Exp $ */ /* Raising exceptions from C. */ @@ -26,112 +26,121 @@ #include "signals.h" #include "stacks.h" -struct longjmp_buffer * external_raise = NULL; -value exn_bucket; +CAMLexport struct longjmp_buffer * caml_external_raise = NULL; +value caml_exn_bucket; -CAMLexport void mlraise(value v) +CAMLexport void caml_raise(value v) { #ifdef DEBUG - extern int volatile async_signal_mode; /* from signals.c */ - Assert(! async_signal_mode); + extern int volatile caml_async_signal_mode; /* from signals.c */ + Assert(! caml_async_signal_mode); #endif Unlock_exn(); - exn_bucket = v; - if (external_raise == NULL) fatal_uncaught_exception(v); - siglongjmp(external_raise->buf, 1); + caml_exn_bucket = v; + if (caml_external_raise == NULL) caml_fatal_uncaught_exception(v); + siglongjmp(caml_external_raise->buf, 1); } -CAMLexport void raise_constant(value tag) +CAMLexport void caml_raise_constant(value tag) { CAMLparam1 (tag); CAMLlocal1 (bucket); - bucket = alloc_small (1, 0); + bucket = caml_alloc_small (1, 0); Field(bucket, 0) = tag; - mlraise(bucket); + caml_raise(bucket); + CAMLnoreturn; } -CAMLexport void raise_with_arg(value tag, value arg) +CAMLexport void caml_raise_with_arg(value tag, value arg) { CAMLparam2 (tag, arg); CAMLlocal1 (bucket); - bucket = alloc_small (2, 0); + bucket = caml_alloc_small (2, 0); Field(bucket, 0) = tag; Field(bucket, 1) = arg; - mlraise(bucket); + caml_raise(bucket); + CAMLnoreturn; } -CAMLexport void raise_with_string(value tag, char *msg) +CAMLexport void caml_raise_with_string(value tag, char *msg) { CAMLparam1 (tag); CAMLlocal1 (vmsg); - vmsg = copy_string(msg); - raise_with_arg(tag, vmsg); + vmsg = caml_copy_string(msg); + caml_raise_with_arg(tag, vmsg); + CAMLnoreturn; } -CAMLexport void failwith (char *msg) +CAMLexport void caml_failwith (char *msg) { - raise_with_string(Field(global_data, FAILURE_EXN), msg); + caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg); } -CAMLexport void invalid_argument (char *msg) +CAMLexport void caml_invalid_argument (char *msg) { - raise_with_string(Field(global_data, INVALID_EXN), msg); + caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg); } -/* Problem: we can't use raise_constant, because it allocates and +CAMLexport void caml_array_bound_error(void) +{ + caml_invalid_argument("index out of bounds"); +} + +/* Problem: we can't use [caml_raise_constant], because it allocates and we're out of memory... Here, we allocate statically the exn bucket - for Out_of_memory. */ + for [Out_of_memory]. */ static struct { header_t hdr; value exn; } out_of_memory_bucket = { 0, 0 }; -CAMLexport void raise_out_of_memory(void) +CAMLexport void caml_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)); + caml_fatal_error + ("Fatal error: out of memory while raising Out_of_memory\n"); + caml_raise((value) &(out_of_memory_bucket.exn)); } -CAMLexport void raise_stack_overflow(void) +CAMLexport void caml_raise_stack_overflow(void) { - raise_constant(Field(global_data, STACK_OVERFLOW_EXN)); + caml_raise_constant(Field(caml_global_data, STACK_OVERFLOW_EXN)); } -CAMLexport void raise_sys_error(value msg) +CAMLexport void caml_raise_sys_error(value msg) { - raise_with_arg(Field(global_data, SYS_ERROR_EXN), msg); + caml_raise_with_arg(Field(caml_global_data, SYS_ERROR_EXN), msg); } -CAMLexport void raise_end_of_file(void) +CAMLexport void caml_raise_end_of_file(void) { - raise_constant(Field(global_data, END_OF_FILE_EXN)); + caml_raise_constant(Field(caml_global_data, END_OF_FILE_EXN)); } -CAMLexport void raise_zero_divide(void) +CAMLexport void caml_raise_zero_divide(void) { - raise_constant(Field(global_data, ZERO_DIVIDE_EXN)); + caml_raise_constant(Field(caml_global_data, ZERO_DIVIDE_EXN)); } -CAMLexport void raise_not_found(void) +CAMLexport void caml_raise_not_found(void) { - raise_constant(Field(global_data, NOT_FOUND_EXN)); + caml_raise_constant(Field(caml_global_data, NOT_FOUND_EXN)); } -CAMLexport void raise_sys_blocked_io(void) +CAMLexport void caml_raise_sys_blocked_io(void) { - raise_constant(Field(global_data, SYS_BLOCKED_IO)); + caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO)); } /* Initialization of statically-allocated exception buckets */ -void init_exceptions(void) +void caml_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); + out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN); + caml_register_global_root(&out_of_memory_bucket.exn); } diff --git a/byterun/fail.h b/byterun/fail.h index 9a2eccd3..9cd2fad2 100644 --- a/byterun/fail.h +++ b/byterun/fail.h @@ -11,14 +11,18 @@ /* */ /***********************************************************************/ -/* $Id: fail.h,v 1.20 2003/06/19 15:53:49 xleroy Exp $ */ +/* $Id: fail.h,v 1.25 2004/01/02 19:23:20 doligez Exp $ */ -#ifndef _fail_ -#define _fail_ +#ifndef CAML_FAIL_H +#define CAML_FAIL_H /* */ #include /* */ + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif #include "misc.h" #include "mlvalues.h" @@ -48,29 +52,25 @@ struct longjmp_buffer { #define siglongjmp(buf,val) longjmp(buf,val) #endif -CAMLextern struct longjmp_buffer * external_raise; -extern value exn_bucket; +CAMLextern struct longjmp_buffer * caml_external_raise; +extern value caml_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); -/* */ +CAMLextern void caml_raise (value bucket) Noreturn; +CAMLextern void caml_raise_constant (value tag) Noreturn; +CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; +CAMLextern void caml_raise_with_string (value tag, char * msg) Noreturn; +CAMLextern void caml_failwith (char *) Noreturn; +CAMLextern void caml_invalid_argument (char *) Noreturn; +CAMLextern void caml_raise_out_of_memory (void) Noreturn; +CAMLextern void caml_raise_stack_overflow (void) Noreturn; +CAMLextern void caml_raise_sys_error (value) Noreturn; +CAMLextern void caml_raise_end_of_file (void) Noreturn; +CAMLextern void caml_raise_zero_divide (void) Noreturn; +CAMLextern void caml_raise_not_found (void) Noreturn; +CAMLextern void caml_init_exceptions (void); +CAMLextern void caml_array_bound_error (void) Noreturn; +CAMLextern void caml_raise_sys_blocked_io (void) Noreturn; -#endif /* _fail_ */ +#endif /* CAML_FAIL_H */ diff --git a/byterun/finalise.c b/byterun/finalise.c index b9af1009..cb1373d9 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: finalise.c,v 1.9 2002/09/18 13:59:27 doligez Exp $ */ +/* $Id: finalise.c,v 1.15.2.1 2004/07/03 10:00:59 doligez Exp $ */ /* Handling of finalised values. */ @@ -27,62 +27,114 @@ struct final { }; static struct final *final_table = NULL; -static unsigned long old = 0, young = 0, active = 0, size = 0; +static unsigned long old = 0, young = 0, size = 0; /* [0..old) : finalisable set [old..young) : recent set - [young..active) : free space - [active..size) : finalising set + [young..size) : free space */ -/* Find white finalisable values, darken them, and put them in the - finalising set. +struct to_do { + struct to_do *next; + int size; + struct final item[1]; /* variable size */ +}; + +static struct to_do *to_do_hd = NULL; +static struct to_do *to_do_tl = NULL; + +static void alloc_to_do (int size) +{ + struct to_do *result = malloc (sizeof (struct to_do) + + size * sizeof (struct final)); + if (result == NULL) caml_fatal_error ("out of memory"); + result->next = NULL; + result->size = size; + if (to_do_tl == NULL){ + to_do_hd = result; + to_do_tl = result; + }else{ + Assert (to_do_tl->next == NULL); + to_do_tl->next = result; + to_do_tl = result; + } +} + +/* Find white finalisable values, put them in the finalising set, and + darken them. The recent set is empty. */ -void final_update (void) +void caml_final_update (void) { - unsigned long i; - unsigned long oldactive = active; + unsigned long i, j, k; + unsigned long todo_count = 0; Assert (young == old); - Assert (young <= active); + for (i = 0; i < old; i++){ + Assert (Is_block (final_table[i].val)); + Assert (Is_in_heap (final_table[i].val)); + if (Is_white_val (final_table[i].val)) ++ todo_count; + } + + alloc_to_do (todo_count); + j = k = 0; 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; + value fv = Forward_val (final_table[i].val); + if (Is_block (fv) && (Is_young (fv) || Is_in_heap (fv)) + && (Tag_val (fv) == Forward_tag || Tag_val (fv) == Lazy_tag + || Tag_val (fv) == Double_tag)){ + /* Do not short-circuit the pointer. */ + }else{ + final_table[i].val = fv; + 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; + to_do_tl->item[k++] = final_table[i]; + }else{ + final_table[j++] = final_table[i]; } } - young = old; - for (i = active; i < oldactive; i++) darken (final_table[i].val, NULL); + old = young = j; + to_do_tl->size = k; + for (i = 0; i < k; i++){ + CAMLassert (Is_white_val (to_do_tl->item[i].val)); + caml_darken (to_do_tl->item[i].val, NULL); + } } +static int running_finalisation_function = 0; + /* Call the finalisation functions for the finalising set. Note that this function must be reentrant. */ -void final_do_calls (void) +void caml_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); + + if (running_finalisation_function) return; + + if (to_do_hd != NULL){ + caml_gc_message (0x80, "Calling finalisation functions.\n", 0); + while (1){ + while (to_do_hd != NULL && to_do_hd->size == 0){ + to_do_hd = to_do_hd->next; + if (to_do_hd == NULL) to_do_tl = NULL; + } + if (to_do_hd == NULL) break; + Assert (to_do_hd->size > 0); + -- to_do_hd->size; + f = to_do_hd->item[to_do_hd->size]; + running_finalisation_function = 1; + caml_callback (f.fun, f.val); + running_finalisation_function = 0; } - gc_message (0x80, "Done calling finalisation functions.\n", 0); + caml_gc_message (0x80, "Done calling finalisation functions.\n", 0); } } @@ -92,19 +144,22 @@ void final_do_calls (void) /* 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]. + This is called by the major GC and the compactor + through [caml_darken_all_roots]. */ -void final_do_strong_roots (scanning_action f) +void caml_final_do_strong_roots (scanning_action f) { unsigned long i; + struct to_do *todo; 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); + + for (todo = to_do_hd; todo != NULL; todo = todo->next){ + for (i = 0; i < todo->size; i++){ + Call_action (f, todo->item[i].fun); + Call_action (f, todo->item[i].val); + } } } @@ -112,7 +167,7 @@ void final_do_strong_roots (scanning_action f) The recent set is empty. This is called directly by the compactor. */ -void final_do_weak_roots (scanning_action f) +void caml_final_do_weak_roots (scanning_action f) { unsigned long i; @@ -121,9 +176,9 @@ void final_do_weak_roots (scanning_action f) } /* Call [*f] on the closures and values of the recent set. - This is called by the minor GC through [oldify_local_roots]. + This is called by the minor GC through [caml_oldify_local_roots]. */ -void final_do_young_roots (scanning_action f) +void caml_final_do_young_roots (scanning_action f) { unsigned long i; @@ -138,41 +193,35 @@ void final_do_young_roots (scanning_action f) 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) +void caml_final_empty_young (void) { old = young; } /* Put (f,v) in the recent set. */ -CAMLprim value final_register (value f, value v) +CAMLprim value caml_final_register (value f, value v) { if (!(Is_block (v) && (Is_in_heap (v) || Is_young (v)))){ - invalid_argument ("Gc.finalise"); + caml_invalid_argument ("Gc.finalise"); } Assert (old <= young); - Assert (young <= active); - Assert (active <= size); - if (young >= active){ + if (young >= size){ if (final_table == NULL){ unsigned long new_size = 30; - final_table = stat_alloc (new_size * sizeof (struct final)); + final_table = caml_stat_alloc (new_size * sizeof (struct final)); Assert (old == 0); Assert (young == 0); - active = size = new_size; + 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; + final_table = caml_stat_resize (final_table, + new_size * sizeof (struct final)); size = new_size; } } - Assert (young < active); + Assert (young < size); final_table[young].fun = f; if (Tag_val (v) == Infix_tag) v -= Infix_offset_val (v); final_table[young].val = v; @@ -180,3 +229,9 @@ CAMLprim value final_register (value f, value v) return Val_unit; } + +CAMLprim value caml_final_release (value unit) +{ + running_finalisation_function = 0; + return Val_unit; +} diff --git a/byterun/finalise.h b/byterun/finalise.h index 0f7a6caf..1ed4925d 100644 --- a/byterun/finalise.h +++ b/byterun/finalise.h @@ -11,14 +11,19 @@ /* */ /***********************************************************************/ -/* $Id: finalise.h,v 1.3 2001/12/07 13:39:27 xleroy Exp $ */ +/* $Id: finalise.h,v 1.5 2004/01/02 19:23:21 doligez Exp $ */ + +#ifndef CAML_FINALISE_H +#define CAML_FINALISE_H #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); +void caml_final_update (void); +void caml_final_do_calls (void); +void caml_final_do_strong_roots (scanning_action f); +void caml_final_do_weak_roots (scanning_action f); +void caml_final_do_young_roots (scanning_action f); +void caml_final_empty_young (void); +value caml_final_register (value f, value v); + +#endif /* CAML_FINALISE_H */ diff --git a/byterun/fix_code.c b/byterun/fix_code.c index e10f00fb..cf732755 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fix_code.c,v 1.26 2002/04/18 07:27:37 garrigue Exp $ */ +/* $Id: fix_code.c,v 1.31 2004/05/26 11:10:51 garrigue Exp $ */ /* Handling of blocks of bytecode (endianness switch, threading). */ @@ -30,38 +30,38 @@ #include "mlvalues.h" #include "reverse.h" -code_t start_code; -asize_t code_size; -unsigned char * saved_code; -unsigned char code_md5[16]; +code_t caml_start_code; +asize_t caml_code_size; +unsigned char * caml_saved_code; +unsigned char caml_code_md5[16]; /* Read the main bytecode block from a file */ -void load_code(int fd, asize_t len) +void caml_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); + caml_code_size = len; + caml_start_code = (code_t) caml_stat_alloc(caml_code_size); + if (read(fd, (char *) caml_start_code, caml_code_size) != caml_code_size) + caml_fatal_error("Fatal error: truncated bytecode file.\n"); + caml_MD5Init(&ctx); + caml_MD5Update(&ctx, (unsigned char *) caml_start_code, caml_code_size); + caml_MD5Final(caml_code_md5, &ctx); #ifdef ARCH_BIG_ENDIAN - fixup_endianness(start_code, code_size); + caml_fixup_endianness(caml_start_code, caml_code_size); #endif - if (debugger_in_use) { + if (caml_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]; + caml_saved_code = (unsigned char *) caml_stat_alloc(len); + for (i = 0; i < len; i++) caml_saved_code[i] = caml_start_code[i]; } #ifdef THREADED_CODE - /* Better to thread now than at the beginning of interprete(), + /* Better to thread now than at the beginning of [caml_interprete], since the debugger interface needs to perform SET_EVENT requests on the code. */ - thread_code(start_code, code_size); + caml_thread_code(caml_start_code, caml_code_size); #endif } @@ -69,7 +69,7 @@ void load_code(int fd, asize_t len) #ifdef ARCH_BIG_ENDIAN -void fixup_endianness(code_t code, asize_t len) +void caml_fixup_endianness(code_t code, asize_t len) { code_t p; len /= sizeof(opcode_t); @@ -84,10 +84,10 @@ void fixup_endianness(code_t code, asize_t len) #ifdef THREADED_CODE -char ** instr_table; -char * instr_base; +char ** caml_instr_table; +char * caml_instr_base; -void thread_code (code_t code, asize_t len) +void caml_thread_code (code_t code, asize_t len) { code_t p; int l [STOP + 1]; @@ -113,18 +113,18 @@ void thread_code (code_t code, asize_t len) 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; + l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 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); + /* FIXME -- should Assert(false) ? + caml_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); + *p++ = (opcode_t)(caml_instr_table[instr] - caml_instr_base); if (instr == SWITCH) { uint32 sizes = *p++; uint32 const_size = sizes & 0xFFFF; @@ -143,19 +143,19 @@ void thread_code (code_t code, asize_t len) #endif /* THREADED_CODE */ -void set_instruction(code_t pos, opcode_t instr) +void caml_set_instruction(code_t pos, opcode_t instr) { #ifdef THREADED_CODE - *pos = (opcode_t)(instr_table[instr] - instr_base); + *pos = (opcode_t)(caml_instr_table[instr] - caml_instr_base); #else *pos = instr; #endif } -int is_instruction(opcode_t instr1, opcode_t instr2) +int caml_is_instruction(opcode_t instr1, opcode_t instr2) { #ifdef THREADED_CODE - return instr1 == (opcode_t)(instr_table[instr2] - instr_base); + return instr1 == (opcode_t)(caml_instr_table[instr2] - caml_instr_base); #else return instr1 == instr2; #endif diff --git a/byterun/fix_code.h b/byterun/fix_code.h index 6e9a597f..c0ec39b8 100644 --- a/byterun/fix_code.h +++ b/byterun/fix_code.h @@ -11,32 +11,32 @@ /* */ /***********************************************************************/ -/* $Id: fix_code.h,v 1.15 2001/12/07 13:39:27 xleroy Exp $ */ +/* $Id: fix_code.h,v 1.17 2004/01/02 19:23:21 doligez Exp $ */ /* Handling of blocks of bytecode (endianness switch, threading). */ -#ifndef _fix_code_ -#define _fix_code_ +#ifndef CAML_FIX_CODE_H +#define CAML_FIX_CODE_H #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]; +extern code_t caml_start_code; +extern asize_t caml_code_size; +extern unsigned char * caml_saved_code; +extern unsigned char caml_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); +void caml_load_code (int fd, asize_t len); +void caml_fixup_endianness (code_t code, asize_t len); +void caml_set_instruction (code_t pos, opcode_t instr); +int caml_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); +extern char ** caml_instr_table; +extern char * caml_instr_base; +void caml_thread_code (code_t code, asize_t len); #endif -#endif +#endif /* CAML_FIX_CODE_H */ diff --git a/byterun/floats.c b/byterun/floats.c index b22b637b..52477a78 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -11,7 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: floats.c,v 1.37 2003/05/05 14:16:29 xleroy Exp $ */ +/* $Id: floats.c,v 1.46 2004/01/09 15:33:31 xleroy Exp $ */ + +/* The interface of this file is in "mlvalues.h" and "alloc.h" */ #include #include @@ -28,7 +30,7 @@ #ifdef ARCH_ALIGN_DOUBLE -CAMLexport double Double_val(value val) +CAMLexport double caml_Double_val(value val) { union { value v[2]; double d; } buffer; @@ -38,7 +40,7 @@ CAMLexport double Double_val(value val) return buffer.d; } -CAMLexport void Store_double_val(value val, double dbl) +CAMLexport void caml_Store_double_val(value val, double dbl) { union { value v[2]; double d; } buffer; @@ -50,7 +52,7 @@ CAMLexport void Store_double_val(value val, double dbl) #endif -CAMLexport value copy_double(double d) +CAMLexport value caml_copy_double(double d) { value res; @@ -63,7 +65,7 @@ CAMLexport value copy_double(double d) return res; } -CAMLprim value format_float(value fmt, value arg) +CAMLprim value caml_format_float(value fmt, value arg) { #define MAX_DIGITS 350 /* Max number of decimal digits in a "natural" (not artificially padded) @@ -94,25 +96,25 @@ CAMLprim value format_float(value fmt, value arg) if (prec < sizeof(format_buffer)) { dest = format_buffer; } else { - dest = stat_alloc(prec); + dest = caml_stat_alloc(prec); } sprintf(dest, String_val(fmt), Double_val(arg)); - res = copy_string(dest); + res = caml_copy_string(dest); if (dest != format_buffer) { - stat_free(dest); + caml_stat_free(dest); } return res; } -CAMLprim value float_of_string(value vs) +CAMLprim value caml_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); + len = caml_string_length(vs); + buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1); src = String_val(vs); dst = buf; while (len--) { @@ -120,97 +122,97 @@ CAMLprim value float_of_string(value vs) if (c != '_') *dst++ = c; } *dst = 0; - if (dst == buf) failwith("float_of_string"); + if (dst == buf) caml_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); + if (buf != parse_buffer) caml_stat_free(buf); + if (end != dst) caml_failwith("float_of_string"); + return caml_copy_double(d); } -CAMLprim value int_of_float(value f) +CAMLprim value caml_int_of_float(value f) { return Val_long((long) Double_val(f)); } -CAMLprim value float_of_int(value n) +CAMLprim value caml_float_of_int(value n) { - return copy_double((double) Long_val(n)); + return caml_copy_double((double) Long_val(n)); } -CAMLprim value neg_float(value f) +CAMLprim value caml_neg_float(value f) { - return copy_double(- Double_val(f)); + return caml_copy_double(- Double_val(f)); } -CAMLprim value abs_float(value f) +CAMLprim value caml_abs_float(value f) { - return copy_double(fabs(Double_val(f))); + return caml_copy_double(fabs(Double_val(f))); } -CAMLprim value add_float(value f, value g) +CAMLprim value caml_add_float(value f, value g) { - return copy_double(Double_val(f) + Double_val(g)); + return caml_copy_double(Double_val(f) + Double_val(g)); } -CAMLprim value sub_float(value f, value g) +CAMLprim value caml_sub_float(value f, value g) { - return copy_double(Double_val(f) - Double_val(g)); + return caml_copy_double(Double_val(f) - Double_val(g)); } -CAMLprim value mul_float(value f, value g) +CAMLprim value caml_mul_float(value f, value g) { - return copy_double(Double_val(f) * Double_val(g)); + return caml_copy_double(Double_val(f) * Double_val(g)); } -CAMLprim value div_float(value f, value g) +CAMLprim value caml_div_float(value f, value g) { - return copy_double(Double_val(f) / Double_val(g)); + return caml_copy_double(Double_val(f) / Double_val(g)); } -CAMLprim value exp_float(value f) +CAMLprim value caml_exp_float(value f) { - return copy_double(exp(Double_val(f))); + return caml_copy_double(exp(Double_val(f))); } -CAMLprim value floor_float(value f) +CAMLprim value caml_floor_float(value f) { - return copy_double(floor(Double_val(f))); + return caml_copy_double(floor(Double_val(f))); } -CAMLprim value fmod_float(value f1, value f2) +CAMLprim value caml_fmod_float(value f1, value f2) { - return copy_double(fmod(Double_val(f1), Double_val(f2))); + return caml_copy_double(fmod(Double_val(f1), Double_val(f2))); } -CAMLprim value frexp_float(value f) +CAMLprim value caml_frexp_float(value f) { CAMLparam1 (f); CAMLlocal2 (res, mantissa); int exponent; - mantissa = copy_double(frexp (Double_val(f), &exponent)); - res = alloc_tuple(2); + mantissa = caml_copy_double(frexp (Double_val(f), &exponent)); + res = caml_alloc_tuple(2); Field(res, 0) = mantissa; Field(res, 1) = Val_int(exponent); CAMLreturn (res); } -CAMLprim value ldexp_float(value f, value i) +CAMLprim value caml_ldexp_float(value f, value i) { - return copy_double(ldexp(Double_val(f), Int_val(i))); + return caml_copy_double(ldexp(Double_val(f), Int_val(i))); } -CAMLprim value log_float(value f) +CAMLprim value caml_log_float(value f) { - return copy_double(log(Double_val(f))); + return caml_copy_double(log(Double_val(f))); } -CAMLprim value log10_float(value f) +CAMLprim value caml_log10_float(value f) { - return copy_double(log10(Double_val(f))); + return caml_copy_double(log10(Double_val(f))); } -CAMLprim value modf_float(value f) +CAMLprim value caml_modf_float(value f) { #if __SC__ _float_eval frem; /* Problem with Apple's */ @@ -220,130 +222,126 @@ CAMLprim value modf_float(value f) CAMLparam1 (f); CAMLlocal3 (res, quo, rem); - quo = copy_double(modf (Double_val(f), &frem)); - rem = copy_double(frem); - res = alloc_tuple(2); + quo = caml_copy_double(modf (Double_val(f), &frem)); + rem = caml_copy_double(frem); + res = caml_alloc_tuple(2); Field(res, 0) = quo; Field(res, 1) = rem; CAMLreturn (res); } -CAMLprim value sqrt_float(value f) +CAMLprim value caml_sqrt_float(value f) { - return copy_double(sqrt(Double_val(f))); + return caml_copy_double(sqrt(Double_val(f))); } -CAMLprim value power_float(value f, value g) +CAMLprim value caml_power_float(value f, value g) { - return copy_double(pow(Double_val(f), Double_val(g))); + return caml_copy_double(pow(Double_val(f), Double_val(g))); } -CAMLprim value sin_float(value f) +CAMLprim value caml_sin_float(value f) { - return copy_double(sin(Double_val(f))); + return caml_copy_double(sin(Double_val(f))); } -CAMLprim value sinh_float(value f) +CAMLprim value caml_sinh_float(value f) { - return copy_double(sinh(Double_val(f))); + return caml_copy_double(sinh(Double_val(f))); } -CAMLprim value cos_float(value f) +CAMLprim value caml_cos_float(value f) { - return copy_double(cos(Double_val(f))); + return caml_copy_double(cos(Double_val(f))); } -CAMLprim value cosh_float(value f) +CAMLprim value caml_cosh_float(value f) { - return copy_double(cosh(Double_val(f))); + return caml_copy_double(cosh(Double_val(f))); } -CAMLprim value tan_float(value f) +CAMLprim value caml_tan_float(value f) { - return copy_double(tan(Double_val(f))); + return caml_copy_double(tan(Double_val(f))); } -CAMLprim value tanh_float(value f) +CAMLprim value caml_tanh_float(value f) { - return copy_double(tanh(Double_val(f))); + return caml_copy_double(tanh(Double_val(f))); } -CAMLprim value asin_float(value f) +CAMLprim value caml_asin_float(value f) { - return copy_double(asin(Double_val(f))); + return caml_copy_double(asin(Double_val(f))); } -CAMLprim value acos_float(value f) +CAMLprim value caml_acos_float(value f) { - return copy_double(acos(Double_val(f))); + return caml_copy_double(acos(Double_val(f))); } -CAMLprim value atan_float(value f) +CAMLprim value caml_atan_float(value f) { - return copy_double(atan(Double_val(f))); + return caml_copy_double(atan(Double_val(f))); } -CAMLprim value atan2_float(value f, value g) +CAMLprim value caml_atan2_float(value f, value g) { - return copy_double(atan2(Double_val(f), Double_val(g))); + return caml_copy_double(atan2(Double_val(f), Double_val(g))); } -CAMLprim value ceil_float(value f) +CAMLprim value caml_ceil_float(value f) { - return copy_double(ceil(Double_val(f))); + return caml_copy_double(ceil(Double_val(f))); } -CAMLprim value eq_float(value f, value g) +CAMLprim value caml_eq_float(value f, value g) { return Val_bool(Double_val(f) == Double_val(g)); } -CAMLprim value neq_float(value f, value g) +CAMLprim value caml_neq_float(value f, value g) { return Val_bool(Double_val(f) != Double_val(g)); } -CAMLprim value le_float(value f, value g) +CAMLprim value caml_le_float(value f, value g) { return Val_bool(Double_val(f) <= Double_val(g)); } -CAMLprim value lt_float(value f, value g) +CAMLprim value caml_lt_float(value f, value g) { return Val_bool(Double_val(f) < Double_val(g)); } -CAMLprim value ge_float(value f, value g) +CAMLprim value caml_ge_float(value f, value g) { return Val_bool(Double_val(f) >= Double_val(g)); } -CAMLprim value gt_float(value f, value g) +CAMLprim value caml_gt_float(value f, value g) { return Val_bool(Double_val(f) > Double_val(g)); } -CAMLprim value float_compare(value vf, value vg) +CAMLprim value caml_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; + if (f == g) return Val_int(0); + if (f < g) return Val_int(-1); + if (f > g) return Val_int(1); + /* One or both of f and g is NaN. Order according to the + convention NaN = NaN and NaN < x for all other floats x. */ + if (f == f) return Val_int(1); /* f is not NaN, g is NaN */ + if (g == g) return Val_int(-1); /* g is not NaN, f is NaN */ + return Val_int(0); /* both f and g are NaN */ } enum { FP_normal, FP_subnormal, FP_zero, FP_infinite, FP_nan }; -CAMLprim value classify_float(value vd) +CAMLprim value caml_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__) @@ -360,15 +358,18 @@ CAMLprim value classify_float(value vd) return Val_int(FP_normal); } #else - double d = Double_val(vd); - uint32 h, l; + union { + double d; #ifdef ARCH_BIG_ENDIAN - h = ((uint32 *) &d)[0]; - l = ((uint32 *) &d)[1]; + struct { uint32 h; uint32 l; } i; #else - l = ((uint32 *) &d)[0]; - h = ((uint32 *) &d)[1]; + struct { uint32 l; uint32 h; } i; #endif + } u; + uint32 h, l; + + u.d = Double_val(vd); + h = u.i.h; l = u.i.l; l = l | (h & 0xFFFFF); h = h & 0x7FF00000; if ((h | l) == 0) @@ -385,7 +386,7 @@ CAMLprim value classify_float(value vd) #endif } -/* The init_ieee_float function should initialize floating-point hardware +/* The [caml_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 @@ -398,7 +399,7 @@ CAMLprim value classify_float(value vd) #endif #endif -void init_ieee_floats(void) +void caml_init_ieee_floats(void) { #if defined(__FreeBSD__) && (__FreeBSD_version < 400017) fpsetmask(0); diff --git a/byterun/freelist.c b/byterun/freelist.c index 51a86aff..df936275 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: freelist.c,v 1.14 2002/12/12 18:59:11 doligez Exp $ */ +/* $Id: freelist.c,v 1.16 2004/01/02 19:23:21 doligez Exp $ */ #include "config.h" #include "freelist.h" @@ -23,7 +23,7 @@ /* The free-list is kept sorted by increasing addresses. This makes the merging of adjacent free blocks possible. - (See [fl_merge_block].) + (See [caml_fl_merge_block].) */ typedef struct { @@ -42,16 +42,16 @@ static struct { #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 + just after [caml_fl_allocate] returns NULL. */ +char *caml_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, +asize_t caml_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) +static void fl_check (void) { char *cur, *prev; int prev_found = 0, merge_found = 0; @@ -63,17 +63,17 @@ void fl_check (void) size_found += Whsize_bp (cur); Assert (Is_in_heap (cur)); if (cur == fl_prev) prev_found = 1; - if (cur == fl_merge) merge_found = 1; + if (cur == caml_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); + Assert (merge_found || caml_fl_merge == Fl_head); + Assert (size_found == caml_fl_cur_size); } #endif -/* [allocate_block] is called by [fl_allocate]. Given a suitable free +/* [allocate_block] is called by [caml_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 @@ -92,30 +92,30 @@ 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); + caml_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; + if (caml_fl_merge == cur) caml_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. */ + calling [caml_fl_allocate] will overwrite it. */ Hd_op (cur) = Make_header (0, 0, Caml_white); }else{ /* Case 2. */ - fl_cur_size -= wh_sz; + caml_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. +/* [caml_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. + [caml_fl_allocate] returns a head pointer. */ -char *fl_allocate (mlsize_t wo_sz) +char *caml_fl_allocate (mlsize_t wo_sz) { char *cur, *prev; Assert (sizeof (char *) == sizeof (value)); @@ -148,33 +148,33 @@ char *fl_allocate (mlsize_t wo_sz) static char *last_fragment; -void fl_init_merge (void) +void caml_fl_init_merge (void) { last_fragment = NULL; - fl_merge = Fl_head; + caml_fl_merge = Fl_head; #ifdef DEBUG fl_check (); #endif } -/* This is called by compact_heap. */ -void fl_reset (void) +/* This is called by caml_compact_heap. */ +void caml_fl_reset (void) { Next (Fl_head) = 0; fl_prev = Fl_head; - fl_cur_size = 0; - fl_init_merge (); + caml_fl_cur_size = 0; + caml_fl_init_merge (); } -/* [fl_merge_block] returns the head pointer of the next block after [bp], +/* [caml_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 *caml_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); + caml_fl_cur_size += Whsize_hd (hd); #ifdef DEBUG { @@ -184,7 +184,7 @@ char *fl_merge_block (char *bp) } } #endif - prev = fl_merge; + prev = caml_fl_merge; cur = Next (prev); /* The sweep code makes sure that this is the right place to insert this block: */ @@ -198,7 +198,7 @@ char *fl_merge_block (char *bp) hd = Make_header (bp_whsz, 0, Caml_white); bp = last_fragment; Hd_bp (bp) = hd; - fl_cur_size += Whsize_wosize (0); + caml_fl_cur_size += Whsize_wosize (0); } } @@ -232,29 +232,29 @@ char *fl_merge_block (char *bp) #ifdef DEBUG Hd_bp (bp) = Debug_free_major; #endif - Assert (fl_merge == prev); + Assert (caml_fl_merge == prev); }else if (Wosize_hd (hd) != 0){ Hd_bp (bp) = Bluehd_hd (hd); Next (bp) = cur; Next (prev) = bp; - fl_merge = bp; + caml_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); + caml_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. + [caml_fl_add_block] can only be called right after a call to + [caml_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) +void caml_fl_add_block (char *bp) { Assert (fl_last != NULL); Assert (Next (fl_last) == NULL); @@ -267,7 +267,7 @@ void fl_add_block (char *bp) } #endif - fl_cur_size += Whsize_bp (bp); + caml_fl_cur_size += Whsize_bp (bp); if (bp > fl_last){ Next (fl_last) = bp; @@ -284,10 +284,10 @@ void fl_add_block (char *bp) 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; + /* When inserting a block between [caml_fl_merge] and [caml_gc_sweep_hp], + we must advance [caml_fl_merge] to the new block, so that [caml_fl_merge] + is always the last free-list block before [caml_gc_sweep_hp]. */ + if (prev == caml_fl_merge && bp <= caml_gc_sweep_hp) caml_fl_merge = bp; } } @@ -298,7 +298,7 @@ void fl_add_block (char *bp) 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) +void caml_make_free_blocks (value *p, mlsize_t size, int do_merge) { mlsize_t sz; @@ -309,7 +309,7 @@ void make_free_blocks (value *p, mlsize_t size, int do_merge) sz = size; } *(header_t *)p = Make_header (Wosize_whsize (sz), 0, Caml_white); - if (do_merge) fl_merge_block (Bp_hp (p)); + if (do_merge) caml_fl_merge_block (Bp_hp (p)); size -= sz; p += sz; } diff --git a/byterun/freelist.h b/byterun/freelist.h index a5b64179..518e768c 100644 --- a/byterun/freelist.h +++ b/byterun/freelist.h @@ -11,25 +11,25 @@ /* */ /***********************************************************************/ -/* $Id: freelist.h,v 1.10 2002/12/12 18:59:11 doligez Exp $ */ +/* $Id: freelist.h,v 1.12 2004/01/02 19:23:21 doligez Exp $ */ /* Free lists of heap blocks. */ -#ifndef _freelist_ -#define _freelist_ +#ifndef CAML_FREELIST_H +#define CAML_FREELIST_H #include "misc.h" #include "mlvalues.h" -extern asize_t fl_cur_size; /* size in words */ +extern asize_t caml_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); +char *caml_fl_allocate (mlsize_t); +void caml_fl_init_merge (void); +void caml_fl_reset (void); +char *caml_fl_merge_block (char *); +void caml_fl_add_block (char *); +void caml_make_free_blocks (value *, mlsize_t, int); -#endif /* _freelist_ */ +#endif /* CAML_FREELIST_H */ diff --git a/byterun/gc.h b/byterun/gc.h index 49dd2180..ffea2c4d 100644 --- a/byterun/gc.h +++ b/byterun/gc.h @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -/* $Id: gc.h,v 1.13 2002/12/16 16:42:12 doligez Exp $ */ +/* $Id: gc.h,v 1.14 2003/12/15 18:10:46 doligez Exp $ */ -#ifndef _gc_ -#define _gc_ +#ifndef CAML_GC_H +#define CAML_GC_H #include "mlvalues.h" @@ -52,4 +52,4 @@ #define Is_black_val(val) (Color_val(val) == Caml_black) -#endif /* _gc_ */ +#endif /* CAML_GC_H */ diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index baf7c676..7278786a 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: gc_ctrl.c,v 1.41 2002/12/15 23:27:06 doligez Exp $ */ +/* $Id: gc_ctrl.c,v 1.47 2004/04/15 15:00:27 doligez Exp $ */ #include "alloc.h" #include "compact.h" @@ -26,23 +26,23 @@ #include "stacks.h" #ifndef NATIVE_CODE -extern unsigned long max_stack_size; /* defined in stacks.c */ +extern unsigned long caml_max_stack_size; /* defined in stacks.c */ #endif -double stat_minor_words = 0.0, - stat_promoted_words = 0.0, - stat_major_words = 0.0; +double caml_stat_minor_words = 0.0, + caml_stat_promoted_words = 0.0, + caml_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; +long caml_stat_minor_collections = 0, + caml_stat_major_collections = 0, + caml_stat_heap_size = 0, /* bytes */ + caml_stat_top_heap_size = 0, /* bytes */ + caml_stat_compactions = 0, + caml_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 */ +extern asize_t caml_major_heap_increment; /* bytes; see major_gc.c */ +extern unsigned long caml_percent_free; /* see major_gc.c */ +extern unsigned long caml_percent_max; /* see compact.c */ #define Next(hp) ((hp) + Bhsize_hp (hp)) @@ -85,7 +85,8 @@ static void check_block (char *hp) switch (Tag_hp (hp)){ case Abstract_tag: break; case String_tag: - /* not true when check_urgent_gc is called by alloc or alloc_string: + /* not true when [caml_check_urgent_gc] is called by [caml_alloc] + or caml_alloc_string: lastbyte = Bosize_val (v) - 1; i = Byte (v, lastbyte); Assert (i >= 0); @@ -128,12 +129,12 @@ static value heap_stats (int returnstats) 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 *chunk = caml_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); + caml_gc_message (-1, "### O'Caml runtime: heap check ###\n", 0); #endif while (chunk != NULL){ @@ -150,9 +151,9 @@ static value heap_stats (int returnstats) ++ fragments; Assert (prev_hp == NULL || Color_hp (prev_hp) != Caml_blue - || cur_hp == gc_sweep_hp); + || cur_hp == caml_gc_sweep_hp); }else{ - if (gc_phase == Phase_sweep && cur_hp >= gc_sweep_hp){ + if (caml_gc_phase == Phase_sweep && cur_hp >= caml_gc_sweep_hp){ ++ free_blocks; free_words += Whsize_hd (cur_hd); if (Whsize_hd (cur_hd) > largest_free){ @@ -185,12 +186,12 @@ static value heap_stats (int returnstats) /* 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); + || cur_hp == caml_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); + || Next (cur_hp) == caml_gc_sweep_hp); */ break; } @@ -200,27 +201,28 @@ static value heap_stats (int returnstats) chunk = Chunk_next (chunk); } - Assert (heap_chunks == stat_heap_chunks); - Assert (live_words + free_words + fragments == Wsize_bsize (stat_heap_size)); + Assert (heap_chunks == caml_stat_heap_chunks); + Assert (live_words + free_words + fragments + == Wsize_bsize (caml_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)); + double minwords = caml_stat_minor_words + + (double) Wsize_bsize (caml_young_end - caml_young_ptr); + double prowords = caml_stat_promoted_words; + double majwords = caml_stat_major_words + (double) caml_allocated_words; + long mincoll = caml_stat_minor_collections; + long majcoll = caml_stat_major_collections; + long heap_words = Wsize_bsize (caml_stat_heap_size); + long cpct = caml_stat_compactions; + long top_heap_words = Wsize_bsize (caml_stat_top_heap_size); + + res = caml_alloc_tuple (15); + Store_field (res, 0, caml_copy_double (minwords)); + Store_field (res, 1, caml_copy_double (prowords)); + Store_field (res, 2, caml_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)); @@ -240,49 +242,85 @@ static value heap_stats (int returnstats) } #ifdef DEBUG -void heap_check (void) +void caml_heap_check (void) { heap_stats (0); } #endif -CAMLprim value gc_stat(value v) +CAMLprim value caml_gc_stat(value v) { Assert (v == Val_unit); return heap_stats (1); } -CAMLprim value gc_counters(value v) +CAMLprim value caml_gc_quick_stat(value v) +{ + CAMLparam0 (); + CAMLlocal1 (res); + + /* get a copy of these before allocating anything... */ + double minwords = caml_stat_minor_words + + (double) Wsize_bsize (caml_young_end - caml_young_ptr); + double prowords = caml_stat_promoted_words; + double majwords = caml_stat_major_words + (double) caml_allocated_words; + long mincoll = caml_stat_minor_collections; + long majcoll = caml_stat_major_collections; + long heap_words = caml_stat_heap_size / sizeof (value); + long top_heap_words = caml_stat_top_heap_size / sizeof (value); + long cpct = caml_stat_compactions; + long heap_chunks = caml_stat_heap_chunks; + + res = caml_alloc_tuple (15); + Store_field (res, 0, caml_copy_double (minwords)); + Store_field (res, 1, caml_copy_double (prowords)); + Store_field (res, 2, caml_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 (0)); + Store_field (res, 8, Val_long (0)); + Store_field (res, 9, Val_long (0)); + Store_field (res, 10, Val_long (0)); + Store_field (res, 11, Val_long (0)); + Store_field (res, 12, Val_long (0)); + Store_field (res, 13, Val_long (cpct)); + Store_field (res, 14, Val_long (top_heap_words)); + CAMLreturn (res); +} + +CAMLprim value caml_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)); + double minwords = caml_stat_minor_words + + (double) Wsize_bsize (caml_young_end - caml_young_ptr); + double prowords = caml_stat_promoted_words; + double majwords = caml_stat_major_words + (double) caml_allocated_words; + + res = caml_alloc_tuple (3); + Store_field (res, 0, caml_copy_double (minwords)); + Store_field (res, 1, caml_copy_double (prowords)); + Store_field (res, 2, caml_copy_double (majwords)); CAMLreturn (res); } -CAMLprim value gc_get(value v) +CAMLprim value caml_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 */ + res = caml_alloc_tuple (6); + Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */ + Store_field (res, 1,Val_long(Wsize_bsize(caml_major_heap_increment)));/* i */ + Store_field (res, 2, Val_long (caml_percent_free)); /* o */ + Store_field (res, 3, Val_long (caml_verb_gc)); /* v */ + Store_field (res, 4, Val_long (caml_percent_max)); /* O */ #ifndef NATIVE_CODE - Store_field (res, 5, Val_long (max_stack_size)); /* l */ + Store_field (res, 5, Val_long (caml_max_stack_size)); /* l */ #else Store_field (res, 5, Val_long (0)); #endif @@ -316,113 +354,111 @@ static long norm_minsize (long int s) return s; } -CAMLprim value gc_set(value v) +CAMLprim value caml_gc_set(value v) { unsigned long newpf, newpm; asize_t newheapincr; asize_t newminsize; - verb_gc = Long_val (Field (v, 3)); + caml_verb_gc = Long_val (Field (v, 3)); #ifndef NATIVE_CODE - change_max_stack_size (Long_val (Field (v, 5))); + caml_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); + if (newpf != caml_percent_free){ + caml_percent_free = newpf; + caml_gc_message (0x20, "New space overhead: %d%%\n", caml_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); + if (newpm != caml_percent_max){ + caml_percent_max = newpm; + caml_gc_message (0x20, "New max overhead: %d%%\n", caml_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); + if (newheapincr != caml_major_heap_increment){ + caml_major_heap_increment = newheapincr; + caml_gc_message (0x20, "New heap increment size: %luk bytes\n", + caml_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); + if (newminsize != caml_minor_heap_size){ + caml_gc_message (0x20, "New minor heap size: %luk bytes\n", + newminsize/1024); + caml_set_minor_heap_size (newminsize); } return Val_unit; } -CAMLprim value gc_minor(value v) +CAMLprim value caml_gc_minor(value v) { Assert (v == Val_unit); - minor_collection (); + caml_minor_collection (); return Val_unit; } -CAMLprim value gc_major(value v) +CAMLprim value caml_gc_major(value v) { Assert (v == Val_unit); - empty_minor_heap (); - finish_major_cycle (); - final_do_calls (); + caml_empty_minor_heap (); + caml_finish_major_cycle (); + caml_final_do_calls (); return Val_unit; } -CAMLprim value gc_full_major(value v) +CAMLprim value caml_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 (); + caml_empty_minor_heap (); + caml_finish_major_cycle (); + caml_final_do_calls (); + caml_empty_minor_heap (); + caml_finish_major_cycle (); + caml_final_do_calls (); return Val_unit; } -CAMLprim value gc_major_slice (value v) +CAMLprim value caml_gc_major_slice (value v) { Assert (Is_long (v)); - empty_minor_heap (); - return Val_long (major_collection_slice (Long_val (v))); + caml_empty_minor_heap (); + return Val_long (caml_major_collection_slice (Long_val (v))); } -CAMLprim value gc_compaction(value v) +CAMLprim value caml_gc_compaction(value v) { Assert (v == Val_unit); - empty_minor_heap (); - finish_major_cycle (); - finish_major_cycle (); - compact_heap (); + caml_empty_minor_heap (); + caml_finish_major_cycle (); + caml_finish_major_cycle (); + caml_compact_heap (); + caml_final_do_calls (); 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) +void caml_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); + caml_gc_message (-1, "### O'Caml runtime: debug mode ###\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); + caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); + caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); + caml_percent_free = norm_pfree (percent_fr); + caml_percent_max = norm_pmax (percent_m); + caml_init_major_heap (major_heap_size); + caml_gc_message (0x20, "Initial minor heap size: %luk bytes\n", + caml_minor_heap_size / 1024); + caml_gc_message (0x20, "Initial major heap size: %luk bytes\n", + major_heap_size / 1024); + caml_gc_message (0x20, "Initial space overhead: %lu%%\n", caml_percent_free); + caml_gc_message (0x20, "Initial max overhead: %lu%%\n", caml_percent_max); + caml_gc_message (0x20, "Initial heap increment: %luk bytes\n", + caml_major_heap_increment / 1024); } diff --git a/byterun/gc_ctrl.h b/byterun/gc_ctrl.h index 3a4151c8..c28e193d 100644 --- a/byterun/gc_ctrl.h +++ b/byterun/gc_ctrl.h @@ -11,32 +11,32 @@ /* */ /***********************************************************************/ -/* $Id: gc_ctrl.h,v 1.13 2002/05/28 16:57:31 doligez Exp $ */ +/* $Id: gc_ctrl.h,v 1.15 2004/01/02 19:23:22 doligez Exp $ */ -#ifndef _gc_ctrl_ -#define _gc_ctrl_ +#ifndef CAML_GC_CTRL_H +#define CAML_GC_CTRL_H #include "misc.h" extern double - stat_minor_words, - stat_promoted_words, - stat_major_words; + caml_stat_minor_words, + caml_stat_promoted_words, + caml_stat_major_words; extern long - stat_minor_collections, - stat_major_collections, - stat_heap_size, - stat_top_heap_size, - stat_compactions, - stat_heap_chunks; + caml_stat_minor_collections, + caml_stat_major_collections, + caml_stat_heap_size, + caml_stat_top_heap_size, + caml_stat_compactions, + caml_stat_heap_chunks; -void init_gc (unsigned long, unsigned long, unsigned long, - unsigned long, unsigned long); +void caml_init_gc (unsigned long, unsigned long, unsigned long, + unsigned long, unsigned long); #ifdef DEBUG -void heap_check (void); +void caml_heap_check (void); #endif -#endif /* _gc_ctrl_ */ +#endif /* CAML_GC_CTRL_H */ diff --git a/byterun/globroots.c b/byterun/globroots.c index 50d2446e..c55b27ff 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: globroots.c,v 1.4 2001/12/07 13:39:28 xleroy Exp $ */ +/* $Id: globroots.c,v 1.7 2004/01/05 20:25:58 doligez Exp $ */ /* Registration of global memory roots */ @@ -55,7 +55,7 @@ struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 }; /* Register a global C root */ -void register_global_root(value *r) +CAMLexport void caml_register_global_root(value *r) { struct global_root * update[MAX_LEVEL]; struct global_root * e, * f; @@ -84,8 +84,8 @@ void register_global_root(value *r) 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 = caml_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]; @@ -95,7 +95,7 @@ void register_global_root(value *r) /* Un-register a global C root */ -void remove_global_root(value *r) +CAMLexport void caml_remove_global_root(value *r) { struct global_root * update[MAX_LEVEL]; struct global_root * e, * f; @@ -121,7 +121,7 @@ void remove_global_root(value *r) update[i]->forward[i] = e->forward[i]; } /* Reclaim list element */ - stat_free(e); + caml_stat_free(e); /* Down-correct list level */ while (caml_global_roots.level > 0 && caml_global_roots.forward[caml_global_roots.level] == NULL) diff --git a/byterun/globroots.h b/byterun/globroots.h index 081fdecb..b9b12d8e 100644 --- a/byterun/globroots.h +++ b/byterun/globroots.h @@ -11,12 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: globroots.h,v 1.2 2001/12/07 13:39:28 xleroy Exp $ */ +/* $Id: globroots.h,v 1.3 2003/12/15 18:10:47 doligez Exp $ */ /* Registration of global memory roots */ -#ifndef _globroots_ -#define _globroots_ +#ifndef CAML_GLOBROOTS_H +#define CAML_GLOBROOTS_H #include "mlvalues.h" @@ -37,4 +37,4 @@ struct global_root_list { extern struct global_root_list caml_global_roots; -#endif /* _globroots */ +#endif /* CAML_GLOBROOTS_H */ diff --git a/byterun/hash.c b/byterun/hash.c index f27bd01f..96defe78 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -11,10 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: hash.c,v 1.19 2002/01/20 17:39:05 doligez Exp $ */ +/* $Id: hash.c,v 1.22 2004/01/02 19:23:22 doligez Exp $ */ /* The generic hashing primitive */ +/* The interface of this file is in "mlvalues.h" */ + #include "mlvalues.h" #include "custom.h" #include "memory.h" @@ -24,7 +26,7 @@ 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) +CAMLprim value caml_hash_univ_param(value count, value limit, value obj) { hash_univ_limit = Long_val(limit); hash_univ_count = Long_val(count); @@ -65,7 +67,7 @@ static void hash_aux(value obj) switch (tag) { case String_tag: hash_univ_count--; - i = string_length(obj); + i = caml_string_length(obj); for (p = &Byte_u(obj, 0); i > 0; i--, p++) Combine_small(*p); break; @@ -140,7 +142,7 @@ static void hash_aux(value obj) /* Hashing variant tags */ -CAMLexport value hash_variant(char * tag) +CAMLexport value caml_hash_variant(char * tag) { value accu; /* Same hashing algorithm as in ../typing/btype.ml, function hash_variant */ @@ -153,4 +155,3 @@ CAMLexport value hash_variant(char * tag) platforms */ return (int32) accu; } - diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index f7baa120..82bc438e 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -11,32 +11,36 @@ /* */ /***********************************************************************/ -/* $Id: instrtrace.c,v 1.12 2003/05/26 12:41:53 xleroy Exp $ */ +/* $Id: instrtrace.c,v 1.19 2004/04/23 23:16:15 basile Exp $ */ /* Trace the instructions executed */ #ifdef DEBUG #include +#include +#include + #include "instruct.h" #include "misc.h" #include "mlvalues.h" #include "opnames.h" #include "prims.h" +#include "stacks.h" -extern code_t start_code; +extern code_t caml_start_code; -long icount = 0; +long caml_icount = 0; -void stop_here () {} +void caml_stop_here () {} -int trace_flag = 0; +int caml_trace_flag = 0; -void disasm_instr(pc) +void caml_disasm_instr(pc) code_t pc; { int instr = *pc; - printf("%6ld %s", (long) (pc - start_code), + printf("%6ld %s", (long) (pc - caml_start_code), instr < 0 || instr > STOP ? "???" : names_of_instructions[instr]); pc++; switch(instr) { @@ -63,10 +67,10 @@ void disasm_instr(pc) 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) + if (pc[0] < 0 || pc[0] >= caml_prim_name_table.size) printf(" unknown primitive %d\n", pc[0]); else - printf(" %s\n", (char *) prim_name_table.contents[pc[0]]); + printf(" %s\n", (char *) caml_prim_name_table.contents[pc[0]]); break; default: printf("\n"); @@ -74,4 +78,196 @@ void disasm_instr(pc) fflush (stdout); } -#endif + + + +char * +caml_instr_string (code_t pc) +{ + static char buf[96]; + char nambuf[36]; + int instr = *pc; + char *nam = 0; + memset (buf, 0, sizeof (buf)); +#define bufprintf(Fmt,...) snprintf(buf,sizeof(buf)-1,Fmt,##__VA_ARGS__) + nam = (instr < 0 || instr > STOP) + ? (snprintf (nambuf, sizeof (nambuf), "???%d", instr), nambuf) + : 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: + bufprintf ("%s %d", nam, 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: + bufprintf ("%s %d, %d", nam, pc[0], pc[1]); + break; + case SWITCH: + bufprintf ("SWITCH sz%#lx=%ld::ntag%ld nint%ld", + (long) pc[0], (long) pc[0], (unsigned long) pc[0] >> 16, + (unsigned long) pc[0] & 0xffff); + break; + /* Instructions with a C primitive as operand */ + case C_CALLN: + bufprintf ("%s %d,", nam, 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] >= caml_prim_name_table.size) + bufprintf ("%s unknown primitive %d", nam, pc[0]); + else + bufprintf ("%s %s", nam, (char *) caml_prim_name_table.contents[pc[0]]); + break; + default: + bufprintf ("%s", nam); + break; + }; + return buf; +} + + +void +caml_trace_value_file (value v, code_t prog, int proglen, FILE * f) +{ + int i; + fprintf (f, "%#lx", v); + if (!v) + return; + if (Is_atom (v)) + fprintf (f, "=atom%ld", v - Atom (0)); + else if (prog && v % sizeof (int) == 0 + && (code_t) v >= prog + && (code_t) v < (code_t) ((char *) prog + proglen)) + fprintf (f, "=code@%d", (code_t) v - prog); + else if (Is_long (v)) + fprintf (f, "=long%ld", Long_val (v)); + else if ((void*)v >= (void*)caml_stack_low + && (void*)v < (void*)caml_stack_high) + fprintf (f, "=stack_%d", (long*)caml_stack_high - (long*)v); + else if (Is_block (v)) { + int s = Wosize_val (v); + int tg = Tag_val (v); + int l = 0; + switch (tg) { + case Closure_tag: + fprintf (f, "=closure[s%d,cod%d]", s, (code_t) (Code_val (v)) - prog); + goto displayfields; + case String_tag: + l = caml_string_length (v); + fprintf (f, "=string[s%dL%d]'", s, l); + for (i = 0; i < ((l>0x1f)?0x1f:l) ; i++) { + if (isprint (Byte (v, i))) + putc (Byte (v, i), f); + else + putc ('?', f); + }; + fprintf (f, "'"); + goto displayfields; + case Double_tag: + fprintf (f, "=float[s%d]=%g", s, Double_val (v)); + goto displayfields; + case Double_array_tag: + fprintf (f, "=floatarray[s%d]", s); + for (i = 0; i < ((s>0xf)?0xf:s); i++) + fprintf (f, " %g", Double_field (v, i)); + goto displayfields; + case Abstract_tag: + fprintf (f, "=abstract[s%d]", s); + goto displayfields; + case Custom_tag: + fprintf (f, "=custom[s%d]", s); + goto displayfields; + default: + fprintf (f, "=block", tg, s); + displayfields: + if (s > 0) + fputs ("=(", f); + for (i = 0; i < s; i++) { + if (i > 20) { + fputs ("....", f); + break; + }; + if (i > 0) + putc (' ', f); + fprintf (f, "%#lx", Field (v, i)); + }; + if (s > 0) + putc (')', f); + }; + } +} + +// added by Basile +void +caml_trace_accu_sp_file (value accu, value * sp, code_t prog, int proglen, + FILE * f) +{ + int i; + value *p; + fprintf (f, "accu="); + caml_trace_value_file (accu, prog, proglen, f); + fprintf (f, "\n sp=%#lx @%d:", (long) sp, caml_stack_high - sp); + for (p = sp, i = 0; i < 12 + (1 << caml_trace_flag) && p < caml_stack_high; + p++, i++) { + fprintf (f, "\n[%d] ", caml_stack_high - p); + caml_trace_value_file (*p, prog, proglen, f); + }; + putc ('\n', f); + fflush (f); +} + +#endif /* DEBUG */ +/* eof $Id: instrtrace.c,v 1.19 2004/04/23 23:16:15 basile Exp $ */ diff --git a/byterun/instrtrace.h b/byterun/instrtrace.h index 67c1eb3d..758c04af 100644 --- a/byterun/instrtrace.h +++ b/byterun/instrtrace.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: instrtrace.h,v 1.6 2001/12/07 13:39:29 xleroy Exp $ */ +/* $Id: instrtrace.h,v 1.8 2004/04/22 09:48:04 basile Exp $ */ /* Trace the instructions executed */ @@ -22,10 +22,10 @@ #include "mlvalues.h" #include "misc.h" -extern int trace_flag; -extern long icount; -void stop_here (void); -void disasm_instr (code_t pc); - - +extern int caml_trace_flag; +extern long caml_icount; +void caml_stop_here (void); +void caml_disasm_instr (code_t pc); +void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f); +void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, FILE * f); #endif diff --git a/byterun/instruct.h b/byterun/instruct.h index af4a5d8d..1e6cda78 100644 --- a/byterun/instruct.h +++ b/byterun/instruct.h @@ -11,10 +11,13 @@ /* */ /***********************************************************************/ -/* $Id: instruct.h,v 1.18 2001/12/07 13:39:29 xleroy Exp $ */ +/* $Id: instruct.h,v 1.20 2004/05/26 11:10:51 garrigue Exp $ */ /* The instruction set. */ +#ifndef CAML_INSTRUCT_H +#define CAML_INSTRUCT_H + enum instructions { ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC, PUSH, @@ -50,6 +53,9 @@ enum instructions { BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT, ULTINT, UGEINT, BULTINT, BUGEINT, + GETPUBMET, GETDYNMET, STOP, EVENT, BREAK }; + +#endif /* CAML_INSTRUCT_H */ diff --git a/byterun/int64_emul.h b/byterun/int64_emul.h index b63dde20..891387f2 100644 --- a/byterun/int64_emul.h +++ b/byterun/int64_emul.h @@ -11,13 +11,22 @@ /* */ /***********************************************************************/ -/* $Id: int64_emul.h,v 1.1 2002/05/25 08:32:53 xleroy Exp $ */ +/* $Id: int64_emul.h,v 1.3 2003/12/15 18:10:47 doligez Exp $ */ /* Software emulation of 64-bit integer arithmetic, for C compilers that do not support it. */ +#ifndef CAML_INT64_EMUL_H +#define CAML_INT64_EMUL_H + #include +#if ARCH_BIG_ENDIAN +#define I64_literal(hi,lo) { hi, lo } +#else +#define I64_literal(hi,lo) { lo, hi } +#endif + /* Unsigned comparison */ static int I64_ucompare(uint64 x, uint64 y) { @@ -28,6 +37,8 @@ static int I64_ucompare(uint64 x, uint64 y) return 0; } +#define I64_ult(x, y) (I64_ucompare(x, y) < 0) + /* Signed comparison */ static int I64_compare(int64 x, int64 y) { @@ -257,3 +268,5 @@ static int64 I64_of_double(double f) if (neg) res = I64_neg(res); return res; } + +#endif /* CAML_INT64_EMUL_H */ diff --git a/byterun/int64_format.h b/byterun/int64_format.h index faf57386..71a1634f 100644 --- a/byterun/int64_format.h +++ b/byterun/int64_format.h @@ -11,11 +11,14 @@ /* */ /***********************************************************************/ -/* $Id: int64_format.h,v 1.1 2002/05/25 08:32:53 xleroy Exp $ */ +/* $Id: int64_format.h,v 1.2 2003/12/15 18:10:47 doligez Exp $ */ /* printf-like formatting of 64-bit integers, in case the C library printf() function does not support them. */ +#ifndef CAML_INT64_FORMAT_H +#define CAML_INT64_FORMAT_H + static void I64_format(char * buffer, char * fmt, int64 x) { static char conv_lower[] = "0123456789abcdef"; @@ -100,3 +103,5 @@ static void I64_format(char * buffer, char * fmt, int64 x) } *p = 0; } + +#endif /* CAML_INT64_FORMAT_H */ diff --git a/byterun/int64_native.h b/byterun/int64_native.h index 7c75410c..178abc5d 100644 --- a/byterun/int64_native.h +++ b/byterun/int64_native.h @@ -11,13 +11,18 @@ /* */ /***********************************************************************/ -/* $Id: int64_native.h,v 1.2 2003/04/01 08:46:38 xleroy Exp $ */ +/* $Id: int64_native.h,v 1.4 2003/12/15 18:10:47 doligez 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 */ +#ifndef CAML_INT64_NATIVE_H +#define CAML_INT64_NATIVE_H + +#define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) #define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) +#define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) #define I64_neg(x) (-(x)) #define I64_add(x,y) ((x) + (y)) #define I64_sub(x,y) ((x) - (y)) @@ -42,3 +47,4 @@ #define I64_to_double(x) ((double)(x)) #define I64_of_double(x) ((int64)(x)) +#endif /* CAML_INT64_NATIVE_H */ diff --git a/byterun/intern.c b/byterun/intern.c index 2e13c247..c03166be 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -11,10 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: intern.c,v 1.50 2002/12/12 18:59:11 doligez Exp $ */ +/* $Id: intern.c,v 1.58 2004/06/19 16:02:07 xleroy Exp $ */ /* Structured input, compact format */ +/* The interface of this file is "intext.h" */ + #include #include "alloc.h" #include "custom.h" @@ -35,14 +37,14 @@ static unsigned char * intern_input; 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. */ +/* 1 if intern_input was allocated by caml_stat_alloc() + and needs caml_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. */ +/* If non-NULL, point to new heap chunk allocated with caml_alloc_for_heap. */ static asize_t obj_counter; /* Count how many objects seen so far */ @@ -98,11 +100,11 @@ static long read64s(void) 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_input_malloced) caml_stat_free(intern_input); + if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); if (intern_extra_block != NULL) { /* free newly allocated heap chunk */ - free_for_heap(intern_extra_block); + caml_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; @@ -176,7 +178,7 @@ static void intern_rec(value *dest) break; #else intern_cleanup(); - failwith("input_value: integer too large"); + caml_failwith("input_value: integer too large"); break; #endif case CODE_SHARED8: @@ -206,7 +208,7 @@ static void intern_rec(value *dest) goto read_block; #else intern_cleanup(); - failwith("input_value: data block too large"); + caml_failwith("input_value: data block too large"); break; #endif case CODE_STRING8: @@ -219,7 +221,7 @@ static void intern_rec(value *dest) case CODE_DOUBLE_BIG: if (sizeof(double) != 8) { intern_cleanup(); - invalid_argument("input_value: non-standard floats"); + caml_invalid_argument("input_value: non-standard floats"); } v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; @@ -243,7 +245,7 @@ static void intern_rec(value *dest) read_double_array: if (sizeof(double) != 8) { intern_cleanup(); - invalid_argument("input_value: non-standard floats"); + caml_invalid_argument("input_value: non-standard floats"); } size = len * Double_wosize; v = Val_hp(intern_dest); @@ -287,11 +289,11 @@ static void intern_rec(value *dest) case CODE_CODEPOINTER: ofs = read32u(); readblock(cksum, 16); - if (memcmp(cksum, code_checksum(), 16) != 0) { + if (memcmp(cksum, caml_code_checksum(), 16) != 0) { intern_cleanup(); - failwith("input_value: code mismatch"); + caml_failwith("input_value: code mismatch"); } - v = (value) (code_area_start + ofs); + v = (value) (caml_code_area_start + ofs); break; case CODE_INFIXPOINTER: ofs = read32u(); @@ -299,10 +301,10 @@ static void intern_rec(value *dest) v = clos + ofs; break; case CODE_CUSTOM: - ops = find_custom_operations((char *) intern_src); + ops = caml_find_custom_operations((char *) intern_src); if (ops == NULL) { intern_cleanup(); - failwith("input_value: unknown custom block identifier"); + caml_failwith("input_value: unknown custom block identifier"); } while (*intern_src++ != 0) /*nothing*/; /*skip identifier*/ size = ops->deserialize((void *) (intern_dest + 2)); @@ -315,7 +317,7 @@ static void intern_rec(value *dest) break; default: intern_cleanup(); - failwith("input_value: ill-formed message"); + caml_failwith("input_value: ill-formed message"); } } } @@ -337,18 +339,18 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) /* 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_extra_block = caml_alloc_for_heap(request); + if (intern_extra_block == NULL) caml_raise_out_of_memory(); + intern_color = caml_allocation_color(intern_extra_block); intern_dest = (header_t *) intern_extra_block; } else { - /* this is a specialised version of alloc from alloc.c */ + /* this is a specialised version of caml_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); + intern_block = caml_alloc_small (wosize, String_tag); }else{ - intern_block = alloc_shr (wosize, String_tag); + intern_block = caml_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 */ } @@ -360,7 +362,7 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) } obj_counter = 0; if (num_objects > 0) - intern_obj_table = (value *) stat_alloc(num_objects * sizeof(value)); + intern_obj_table = (value *) caml_stat_alloc(num_objects * sizeof(value)); else intern_obj_table = NULL; } @@ -376,37 +378,37 @@ static void intern_add_to_heap(mlsize_t whsize) (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); + caml_make_free_blocks ((value *) intern_dest, + end_extra_block - intern_dest, 0); } - add_to_heap(intern_extra_block); + caml_add_to_heap(intern_extra_block); } } -value input_val(struct channel *chan) +value caml_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); + if (! caml_channel_binary_mode(chan)) + caml_failwith("input_value: not a binary channel"); + magic = caml_getword(chan); + if (magic != Intext_magic_number) caml_failwith("input_value: bad object"); + block_len = caml_getword(chan); + num_objects = caml_getword(chan); + size_32 = caml_getword(chan); + size_64 = caml_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"); + block = caml_stat_alloc(block_len); + /* During [caml_really_getblock], concurrent [caml_input_val] operations + can take place (via signal handlers or context switching in systhreads), + and [intern_input] may change. So, wait until [caml_really_getblock] + is over before using [intern_input] and the other global vars. */ + if (caml_really_getblock(chan, block, block_len) == 0) { + caml_stat_free(block); + caml_failwith("input_value: truncated object"); } intern_input = (unsigned char *) block; intern_input_malloced = 1; @@ -422,24 +424,24 @@ value input_val(struct channel *chan) intern_rec(&res); intern_add_to_heap(whsize); /* Free everything */ - stat_free(intern_input); - if (intern_obj_table != NULL) stat_free(intern_obj_table); + caml_stat_free(intern_input); + if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); return res; } -CAMLprim value input_value(value vchan) +CAMLprim value caml_input_value(value vchan) { CAMLparam1 (vchan); struct channel * chan = Channel(vchan); CAMLlocal1 (res); Lock(chan); - res = input_val(chan); + res = caml_input_val(chan); Unlock(chan); CAMLreturn (res); } -CAMLexport value input_val_from_string(value str, long int ofs) +CAMLexport value caml_input_val_from_string(value str, long int ofs) { CAMLparam1 (str); mlsize_t num_objects, size_32, size_64, whsize; @@ -462,13 +464,13 @@ CAMLexport value input_val_from_string(value str, long int ofs) intern_rec(&obj); intern_add_to_heap(whsize); /* Free everything */ - if (intern_obj_table != NULL) stat_free(intern_obj_table); + if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); CAMLreturn (obj); } -CAMLprim value input_value_from_string(value str, value ofs) +CAMLprim value caml_input_value_from_string(value str, value ofs) { - return input_val_from_string(str, Long_val(ofs)); + return caml_input_val_from_string(str, Long_val(ofs)); } static value input_val_from_block(void) @@ -490,13 +492,14 @@ static value input_val_from_block(void) intern_rec(&obj); intern_add_to_heap(whsize); /* Free internal data structures */ - if (intern_obj_table != NULL) stat_free(intern_obj_table); + if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); return obj; } -CAMLexport value input_value_from_malloc(char * data, long ofs) +CAMLexport value caml_input_value_from_malloc(char * data, long ofs) { - mlsize_t magic, block_len; + uint32 magic; + mlsize_t block_len; value obj; intern_input = (unsigned char *) data; @@ -504,17 +507,18 @@ CAMLexport value input_value_from_malloc(char * data, long ofs) intern_input_malloced = 1; magic = read32u(); if (magic != Intext_magic_number) - failwith("input_value_from_malloc: bad object"); + caml_failwith("input_value_from_malloc: bad object"); block_len = read32u(); obj = input_val_from_block(); /* Free the input */ - stat_free(intern_input); + caml_stat_free(intern_input); return obj; } -CAMLexport value input_value_from_block(char * data, long len) +CAMLexport value caml_input_value_from_block(char * data, long len) { - mlsize_t magic, block_len; + uint32 magic; + mlsize_t block_len; value obj; intern_input = (unsigned char *) data; @@ -522,15 +526,15 @@ CAMLexport value input_value_from_block(char * data, long len) intern_input_malloced = 0; magic = read32u(); if (magic != Intext_magic_number) - failwith("input_value_from_block: bad object"); + caml_failwith("input_value_from_block: bad object"); block_len = read32u(); if (5*4 + block_len > len) - failwith("input_value_from_block: bad block length"); + caml_failwith("input_value_from_block: bad block length"); obj = input_val_from_block(); return obj; } -CAMLprim value marshal_data_size(value buff, value ofs) +CAMLprim value caml_marshal_data_size(value buff, value ofs) { uint32 magic; mlsize_t block_len; @@ -538,7 +542,9 @@ CAMLprim value marshal_data_size(value buff, value ofs) 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"); + if (magic != Intext_magic_number){ + caml_failwith("Marshal.data_size: bad object"); + } block_len = read32u(); return Val_long(block_len); } @@ -549,18 +555,18 @@ CAMLprim value marshal_data_size(value buff, value ofs) #include "md5.h" -unsigned char * code_checksum() +unsigned char * caml_code_checksum(void) { 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); + caml_MD5Init(&ctx); + caml_MD5Update(&ctx, + (unsigned char *) caml_code_area_start, + caml_code_area_end - caml_code_area_start); + caml_MD5Final(checksum, &ctx); checksum_computed = 1; } return checksum; @@ -570,83 +576,83 @@ unsigned char * code_checksum() #include "fix_code.h" -unsigned char * code_checksum(void) +unsigned char * caml_code_checksum(void) { - return code_md5; + return caml_code_md5; } #endif /* Functions for writing user-defined marshallers */ -CAMLexport int deserialize_uint_1(void) +CAMLexport int caml_deserialize_uint_1(void) { return read8u(); } -CAMLexport int deserialize_sint_1(void) +CAMLexport int caml_deserialize_sint_1(void) { return read8s(); } -CAMLexport int deserialize_uint_2(void) +CAMLexport int caml_deserialize_uint_2(void) { return read16u(); } -CAMLexport int deserialize_sint_2(void) +CAMLexport int caml_deserialize_sint_2(void) { return read16s(); } -CAMLexport uint32 deserialize_uint_4(void) +CAMLexport uint32 caml_deserialize_uint_4(void) { return read32u(); } -CAMLexport int32 deserialize_sint_4(void) +CAMLexport int32 caml_deserialize_sint_4(void) { return read32s(); } -CAMLexport uint64 deserialize_uint_8(void) +CAMLexport uint64 caml_deserialize_uint_8(void) { uint64 i; - deserialize_block_8(&i, 1); + caml_deserialize_block_8(&i, 1); return i; } -CAMLexport int64 deserialize_sint_8(void) +CAMLexport int64 caml_deserialize_sint_8(void) { int64 i; - deserialize_block_8(&i, 1); + caml_deserialize_block_8(&i, 1); return i; } -CAMLexport float deserialize_float_4(void) +CAMLexport float caml_deserialize_float_4(void) { float f; - deserialize_block_4(&f, 1); + caml_deserialize_block_4(&f, 1); return f; } -CAMLexport double deserialize_float_8(void) +CAMLexport double caml_deserialize_float_8(void) { double f; - deserialize_block_float_8(&f, 1); + caml_deserialize_block_float_8(&f, 1); return f; } -CAMLexport void deserialize_block_1(void * data, long len) +CAMLexport void caml_deserialize_block_1(void * data, long len) { memmove(data, intern_src, len); intern_src += len; } -CAMLexport void deserialize_block_2(void * data, long len) +CAMLexport void caml_deserialize_block_2(void * data, long len) { - unsigned char * p, * q; #ifndef ARCH_BIG_ENDIAN + unsigned char * p, * q; for (p = intern_src, q = data; len > 0; len--, p += 2, q += 2) Reverse_16(q, p); intern_src = p; @@ -656,10 +662,10 @@ CAMLexport void deserialize_block_2(void * data, long len) #endif } -CAMLexport void deserialize_block_4(void * data, long len) +CAMLexport void caml_deserialize_block_4(void * data, long len) { - unsigned char * p, * q; #ifndef ARCH_BIG_ENDIAN + unsigned char * p, * q; for (p = intern_src, q = data; len > 0; len--, p += 4, q += 4) Reverse_32(q, p); intern_src = p; @@ -669,10 +675,10 @@ CAMLexport void deserialize_block_4(void * data, long len) #endif } -CAMLexport void deserialize_block_8(void * data, long len) +CAMLexport void caml_deserialize_block_8(void * data, long len) { - unsigned char * p, * q; #ifndef ARCH_BIG_ENDIAN + unsigned char * p, * q; for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) Reverse_64(q, p); intern_src = p; @@ -682,25 +688,26 @@ CAMLexport void deserialize_block_8(void * data, long len) #endif } -CAMLexport void deserialize_block_float_8(void * data, long len) +CAMLexport void caml_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 + unsigned char * p, * q; for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) Reverse_64(q, p); intern_src = p; #else + unsigned char * p, * q; 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) +CAMLexport void caml_deserialize_error(char * msg) { intern_cleanup(); - failwith(msg); + caml_failwith(msg); } diff --git a/byterun/interp.c b/byterun/interp.c index f7bb50d4..f737dbb7 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: interp.c,v 1.76 2003/06/30 08:28:46 xleroy Exp $ */ +/* $Id: interp.c,v 1.90 2004/06/12 10:40:52 xleroy Exp $ */ /* The bytecode interpreter */ #include @@ -37,10 +37,10 @@ sp the stack pointer (grows downward) accu the accumulator env heap-allocated environment - trapsp pointer to the current trap frame + caml_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. */ +sp is a local copy of the global variable caml_extern_sp. */ /* Instruction decoding */ @@ -68,10 +68,11 @@ sp is a local copy of the global variable extern_sp. */ /* GC interface */ -#define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = env; extern_sp = sp; } +#define Setup_for_gc \ + { sp -= 2; sp[0] = accu; sp[1] = env; caml_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++; } +#define Setup_for_c_call { saved_pc = pc; *--sp = env; caml_extern_sp = sp; } +#define Restore_after_c_call { sp = caml_extern_sp; env = *sp++; } /* An event frame must look like accu + a C_CALL frame + a RETURN 1 frame */ #define Setup_for_event \ @@ -82,9 +83,9 @@ sp is a local copy of the global variable extern_sp. */ 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; } + caml_extern_sp = sp; } #define Restore_after_event \ - { sp = extern_sp; accu = sp[0]; \ + { sp = caml_extern_sp; accu = sp[0]; \ pc = (code_t) sp[3]; env = sp[4]; extra_args = Long_val(sp[5]); \ sp += 6; } @@ -94,15 +95,15 @@ sp is a local copy of the global variable extern_sp. */ { sp -= 4; \ sp[0] = accu; sp[1] = (value)(pc - 1); \ sp[2] = env; sp[3] = Val_long(extra_args); \ - extern_sp = sp; } + caml_extern_sp = sp; } #define Restore_after_debugger { sp += 4; } #ifdef THREADED_CODE #define Restart_curr_instr \ - goto *(jumptable[saved_code[pc - 1 - start_code]]) + goto *(jumptable[caml_saved_code[pc - 1 - caml_start_code]]) #else #define Restart_curr_instr \ - curr_instr = saved_code[pc - 1 - start_code]; \ + curr_instr = caml_saved_code[pc - 1 - caml_start_code]; \ goto dispatch_instr #endif @@ -113,7 +114,7 @@ sp is a local copy of the global variable extern_sp. */ For GCC, I have hand-assigned hardware registers for several architectures. */ -#if defined(__GNUC__) && !defined(DEBUG) +#if defined(__GNUC__) && !defined(__INTEL_COMPILER) && !defined(DEBUG) #ifdef __mips__ #define PC_REG asm("$16") #define SP_REG asm("$17") @@ -182,9 +183,14 @@ extern long caml_safe_div(long p, long q); extern long caml_safe_mod(long p, long q); #endif + +#ifdef DEBUG +static long caml_bcodcount; +#endif + /* The interpreter itself */ -value interprete(code_t prog, asize_t prog_size) +value caml_interprete(code_t prog, asize_t prog_size) { #ifdef PC_REG register code_t pc PC_REG; @@ -206,15 +212,15 @@ value interprete(code_t prog, asize_t prog_size) 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) */ + /* volatile ensures that initial_local_roots and saved_pc + will keep correct value across longjmp */ struct caml__roots_block * volatile initial_local_roots; + volatile code_t saved_pc; 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[] = { @@ -224,8 +230,8 @@ value interprete(code_t prog, asize_t prog_size) if (prog == NULL) { /* Interpreter is initializing */ #ifdef THREADED_CODE - instr_table = (char **) jumptable; - instr_base = Jumptbl_base; + caml_instr_table = (char **) jumptable; + caml_instr_base = Jumptbl_base; #endif return Val_unit; } @@ -233,22 +239,22 @@ value interprete(code_t prog, asize_t prog_size) #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++; + initial_local_roots = caml_local_roots; + initial_sp_offset = (char *) caml_stack_high - (char *) caml_extern_sp; + initial_external_raise = caml_external_raise; + caml_callback_depth++; saved_pc = NULL; if (sigsetjmp(raise_buf.buf, 0)) { - local_roots = initial_local_roots; - sp = extern_sp; - accu = exn_bucket; + caml_local_roots = initial_local_roots; + sp = caml_extern_sp; + accu = caml_exn_bucket; pc = saved_pc + 2; /* +2 adjustement for the sole purpose of backtraces */ goto raise_exception; } - external_raise = &raise_buf; + caml_external_raise = &raise_buf; - sp = extern_sp; + sp = caml_extern_sp; pc = prog; extra_args = 0; env = Atom(0); @@ -257,18 +263,27 @@ value interprete(code_t prog, asize_t prog_size) #ifdef THREADED_CODE #ifdef DEBUG next_instr: - if (icount-- == 0) stop_here (); - Assert(sp >= stack_low); - Assert(sp <= stack_high); + if (caml_icount-- == 0) caml_stop_here (); + Assert(sp >= caml_stack_low); + Assert(sp <= caml_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); + caml_bcodcount++; + if (caml_icount-- == 0) caml_stop_here (); + if (caml_trace_flag>1) printf("\n##%ld\n", caml_bcodcount); + if (caml_trace_flag) caml_disasm_instr(pc); + if (caml_trace_flag>1) { + printf("env="); + caml_trace_value_file(env,prog,prog_size,stdout); + putchar('\n'); + caml_trace_accu_sp_file(accu,sp,prog,prog_size,stdout); + fflush(stdout); + }; + Assert(sp >= caml_stack_low); + Assert(sp <= caml_stack_high); #endif curr_instr = *pc++; @@ -570,7 +585,7 @@ value interprete(code_t prog, asize_t prog_size) *--sp = accu; /* Fallthrough */ Instruct(GETGLOBAL): - accu = Field(global_data, *pc); + accu = Field(caml_global_data, *pc); pc++; Next; @@ -578,7 +593,7 @@ value interprete(code_t prog, asize_t prog_size) *--sp = accu; /* Fallthrough */ Instruct(GETGLOBALFIELD): { - accu = Field(global_data, *pc); + accu = Field(caml_global_data, *pc); pc++; accu = Field(accu, *pc); pc++; @@ -586,7 +601,7 @@ value interprete(code_t prog, asize_t prog_size) } Instruct(SETGLOBAL): - modify(&Field(global_data, *pc), accu); + caml_modify(&Field(caml_global_data, *pc), accu); accu = Val_unit; pc++; Next; @@ -615,9 +630,9 @@ value interprete(code_t prog, asize_t prog_size) 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++); + block = caml_alloc_shr(wosize, tag); + caml_initialize(&Field(block, 0), accu); + for (i = 1; i < wosize; i++) caml_initialize(&Field(block, i), *sp++); } accu = block; Next; @@ -658,7 +673,7 @@ value interprete(code_t prog, asize_t prog_size) 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); + block = caml_alloc_shr(size * Double_wosize, Double_array_tag); } Store_double_field(block, 0, Double_val(accu)); for (i = 1; i < size; i++){ @@ -784,38 +799,40 @@ value interprete(code_t prog, asize_t prog_size) Instruct(PUSHTRAP): sp -= 4; Trap_pc(sp) = pc + *pc; - Trap_link(sp) = trapsp; + Trap_link(sp) = caml_trapsp; sp[2] = env; sp[3] = Val_long(extra_args); - trapsp = sp; + caml_trapsp = sp; pc++; Next; Instruct(POPTRAP): - if (something_to_do) { + if (caml_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); + caml_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--; + if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); + if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp); + if ((char *) caml_trapsp + >= (char *) caml_stack_high - initial_sp_offset) { + caml_external_raise = initial_external_raise; + caml_extern_sp = (value *) ((char *) caml_stack_high + - initial_sp_offset); + caml_callback_depth--; return Make_exception_result(accu); } - sp = trapsp; + sp = caml_trapsp; pc = Trap_pc(sp); - trapsp = Trap_link(sp); + caml_trapsp = Trap_link(sp); env = sp[2]; extra_args = Long_val(sp[3]); sp += 4; @@ -824,23 +841,23 @@ value interprete(code_t prog, asize_t prog_size) /* Stack checks */ check_stacks: - if (sp < stack_threshold) { - extern_sp = sp; - realloc_stack(Stack_threshold / sizeof(value)); - sp = extern_sp; + if (sp < caml_stack_threshold) { + caml_extern_sp = sp; + caml_realloc_stack(Stack_threshold / sizeof(value)); + sp = caml_extern_sp; } /* Fall through CHECK_SIGNALS */ /* Signal handling */ Instruct(CHECK_SIGNALS): /* accu not preserved */ - if (something_to_do) goto process_signal; + if (caml_something_to_do) goto process_signal; Next; process_signal: - something_to_do = 0; + caml_something_to_do = 0; Setup_for_event; - process_event(); + caml_process_event(); Restore_after_event; Next; @@ -932,7 +949,7 @@ value interprete(code_t prog, asize_t prog_size) Instruct(DIVINT): { long divisor = Long_val(*sp++); - if (divisor == 0) { Setup_for_c_call; raise_zero_divide(); } + if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } #ifdef NONSTANDARD_DIV_MOD accu = Val_long(caml_safe_div(Long_val(accu), divisor)); #else @@ -942,7 +959,7 @@ value interprete(code_t prog, asize_t prog_size) } Instruct(MODINT): { long divisor = Long_val(*sp++); - if (divisor == 0) { Setup_for_c_call; raise_zero_divide(); } + if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } #ifdef NONSTANDARD_DIV_MOD accu = Val_long(caml_safe_mod(Long_val(accu), divisor)); #else @@ -1009,33 +1026,92 @@ value interprete(code_t prog, asize_t prog_size) /* Object-oriented operations */ -#define Lookup(obj, lab) \ - Field (Field (Field (obj, 0), ((lab) >> 16) / sizeof (value)), \ - ((lab) / sizeof (value)) & 0xFF) +#define Lookup(obj, lab) Field (Field (obj, 0), Int_val(lab)) + + /* please don't forget to keep below code in sync with the + functions caml_cache_public_method and + caml_cache_public_method2 in obj.c */ Instruct(GETMETHOD): accu = Lookup(sp[0], accu); Next; +#define CAML_METHOD_CACHE +#ifdef CAML_METHOD_CACHE + Instruct(GETPUBMET): { + /* accu == object, pc[0] == tag, pc[1] == cache */ + value meths = Field (accu, 0); + value ofs; +#ifdef CAML_TEST_CACHE + static int calls = 0, hits = 0; + if (calls >= 10000000) { + fprintf(stderr, "cache hit = %d%%\n", hits / 100000); + calls = 0; hits = 0; + } + calls++; +#endif + *--sp = accu; + accu = Val_int(*pc++); + ofs = *pc & Field(meths,1); + if (*(value*)(((char*)&Field(meths,3)) + ofs) == accu) { +#ifdef CAML_TEST_CACHE + hits++; +#endif + accu = *(value*)(((char*)&Field(meths,2)) + ofs); + } + else + { + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (accu < Field(meths,mi)) hi = mi-2; + else li = mi; + } + *pc = (li-3)*sizeof(value); + accu = Field (meths, li-1); + } + pc++; + Next; + } +#else + Instruct(GETPUBMET): + *--sp = accu; + accu = Val_int(*pc); + pc += 2; + /* Fallthrough */ +#endif + Instruct(GETDYNMET): { + /* accu == tag, sp[0] == object, *pc == cache */ + value meths = Field (sp[0], 0); + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (accu < Field(meths,mi)) hi = mi-2; + else li = mi; + } + accu = Field (meths, li-1); + Next; + } + /* Debugging and machine control */ Instruct(STOP): - external_raise = initial_external_raise; - extern_sp = sp; - callback_depth--; + caml_external_raise = initial_external_raise; + caml_extern_sp = sp; + caml_callback_depth--; return accu; Instruct(EVENT): - if (--event_count == 0) { + if (--caml_event_count == 0) { Setup_for_debugger; - debugger(EVENT_COUNT); + caml_debugger(EVENT_COUNT); Restore_after_debugger; } Restart_curr_instr; Instruct(BREAK): Setup_for_debugger; - debugger(BREAKPOINT); + caml_debugger(BREAKPOINT); Restore_after_debugger; Restart_curr_instr; @@ -1044,10 +1120,29 @@ value interprete(code_t prog, asize_t prog_size) #if _MSC_VER >= 1200 __assume(0); #else - fatal_error_arg("Fatal error: bad opcode (%lx)\n", - (char *)(long)(*(pc-1))); + caml_fatal_error_arg("Fatal error: bad opcode (%lx)\n", + (char *)(long)(*(pc-1))); #endif } } #endif } + +void caml_prepare_bytecode(code_t prog, asize_t prog_size) { + /* other implementations of the interpreter (such as an hypothetical + JIT translator) might want to do something with a bytecode before + running it */ + Assert(prog); + Assert(prog_size>0); + /* actually, the threading of the bytecode might be done here */ +} + +void caml_release_bytecode(code_t prog, asize_t prog_size) { + /* other implementations of the interpreter (such as an hypothetical + JIT translator) might want to know when a bytecode is removed */ + /* check that we have a program */ + Assert(prog); + Assert(prog_size>0); +} + +/* eof $Id: interp.c,v 1.90 2004/06/12 10:40:52 xleroy Exp $ */ diff --git a/byterun/interp.h b/byterun/interp.h index 650aa8d5..299b0917 100644 --- a/byterun/interp.h +++ b/byterun/interp.h @@ -11,18 +11,23 @@ /* */ /***********************************************************************/ -/* $Id: interp.h,v 1.8 2001/12/07 13:39:30 xleroy Exp $ */ +/* $Id: interp.h,v 1.13 2004/04/26 14:08:22 basile Exp $ */ /* The bytecode interpreter */ -#ifndef _interp_ -#define _interp_ - +#ifndef CAML_INTERP_H +#define CAML_INTERP_H #include "misc.h" #include "mlvalues.h" -value interprete (code_t prog, asize_t prog_size); +/* interpret a bytecode */ +value caml_interprete (code_t prog, asize_t prog_size); + +/* tell the runtime that a bytecode program might be needed */ +void caml_prepare_bytecode(code_t prog, asize_t prog_size); +/* tell the runtime that a bytecode program is no more needed */ +void caml_release_bytecode(code_t prog, asize_t prog_size); -#endif +#endif /* CAML_INTERP_H */ diff --git a/byterun/intext.h b/byterun/intext.h index bdc38d03..8b33ec25 100644 --- a/byterun/intext.h +++ b/byterun/intext.h @@ -11,13 +11,16 @@ /* */ /***********************************************************************/ -/* $Id: intext.h,v 1.25 2002/11/25 14:40:32 xleroy Exp $ */ +/* $Id: intext.h,v 1.30 2004/01/02 19:23:23 doligez Exp $ */ /* Structured input/output */ -#ifndef __intext__ -#define __intext__ +#ifndef CAML_INTEXT_H +#define CAML_INTEXT_H +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif #include "misc.h" #include "mlvalues.h" @@ -87,38 +90,38 @@ /* The entry points */ -CAMLextern void output_val (struct channel * chan, value v, value flags); +void caml_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); +CAMLextern void caml_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); +CAMLextern long caml_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); +value caml_input_val (struct channel * chan); /* Read a structured value from the channel [chan]. */ /* */ -CAMLextern value input_val_from_string (value str, long ofs); +CAMLextern value caml_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); +CAMLextern value caml_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); +CAMLextern value caml_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. @@ -126,49 +129,48 @@ CAMLextern value input_value_from_block(char * data, long len); /* 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); +CAMLextern void caml_serialize_int_1(int i); +CAMLextern void caml_serialize_int_2(int i); +CAMLextern void caml_serialize_int_4(int32 i); +CAMLextern void caml_serialize_int_8(int64 i); +CAMLextern void caml_serialize_float_4(float f); +CAMLextern void caml_serialize_float_8(double f); +CAMLextern void caml_serialize_block_1(void * data, long len); +CAMLextern void caml_serialize_block_2(void * data, long len); +CAMLextern void caml_serialize_block_4(void * data, long len); +CAMLextern void caml_serialize_block_8(void * data, long len); +CAMLextern void caml_serialize_block_float_8(void * data, long len); + +CAMLextern int caml_deserialize_uint_1(void); +CAMLextern int caml_deserialize_sint_1(void); +CAMLextern int caml_deserialize_uint_2(void); +CAMLextern int caml_deserialize_sint_2(void); +CAMLextern uint32 caml_deserialize_uint_4(void); +CAMLextern int32 caml_deserialize_sint_4(void); +CAMLextern uint64 caml_deserialize_uint_8(void); +CAMLextern int64 caml_deserialize_sint_8(void); +CAMLextern float caml_deserialize_float_4(void); +CAMLextern double caml_deserialize_float_8(void); +CAMLextern void caml_deserialize_block_1(void * data, long len); +CAMLextern void caml_deserialize_block_2(void * data, long len); +CAMLextern void caml_deserialize_block_4(void * data, long len); +CAMLextern void caml_deserialize_block_8(void * data, long len); +CAMLextern void caml_deserialize_block_float_8(void * data, long len); +CAMLextern void caml_deserialize_error(char * msg); /* */ /* Auxiliary stuff for sending code pointers */ -unsigned char * code_checksum (void); +unsigned char * caml_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) +#define caml_code_area_start ((char *) caml_start_code) +#define caml_code_area_end ((char *) caml_start_code + caml_code_size) #else -extern char * code_area_start, * code_area_end; +extern char * caml_code_area_start, * caml_code_area_end; #endif /* */ -#endif - +#endif /* CAML_INTEXT_H */ diff --git a/byterun/ints.c b/byterun/ints.c index 5c8f5243..769f5522 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: ints.c,v 1.40 2003/06/23 11:27:05 xleroy Exp $ */ +/* $Id: ints.c,v 1.47 2004/01/02 19:23:23 doligez Exp $ */ #include #include @@ -58,23 +58,40 @@ static int parse_digit(char c) return -1; } -static long parse_long(value s) +static long parse_long(value s, int nbits) { char * p; - unsigned long res; + unsigned long res, threshold; int sign, base, d; p = parse_sign_and_base(String_val(s), &base, &sign); + threshold = ((unsigned long) -1) / base; d = parse_digit(*p); - if (d < 0 || d >= base) failwith("int_of_string"); + if (d < 0 || d >= base) caml_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; + /* Detect overflow in multiplication base * res */ + if (res > threshold) caml_failwith("int_of_string"); res = base * res + d; + /* Detect overflow in addition (base * res) + d */ + if (res < (unsigned long) d) caml_failwith("int_of_string"); + } + if (p != String_val(s) + caml_string_length(s)){ + caml_failwith("int_of_string"); + } + if (base == 10) { + /* Signed representation expected, allow -2^(nbits-1) to 2^(nbits - 1) */ + if (res > 1UL << (nbits - 1)) + caml_failwith("int_of_string"); + } else { + /* Unsigned representation expected, allow 0 to 2^nbits - 1 + and tolerate -(2^nbits - 1) to 0 */ + if (nbits < sizeof(unsigned long) * 8 && res >= 1UL << nbits) + caml_failwith("int_of_string"); } - if (p != String_val(s) + string_length(s)) failwith("int_of_string"); return sign < 0 ? -((long) res) : (long) res; } @@ -98,15 +115,15 @@ long caml_safe_mod(long p, long q) /* Tagged integers */ -CAMLprim value int_compare(value v1, value v2) +CAMLprim value caml_int_compare(value v1, value v2) { int res = (v1 > v2) - (v1 < v2); return Val_int(res); } -CAMLprim value int_of_string(value s) +CAMLprim value caml_int_of_string(value s) { - return Val_long(parse_long(s)); + return Val_long(parse_long(s, 8 * sizeof(value) - 1)); } #define FORMAT_BUFFER_SIZE 32 @@ -124,10 +141,10 @@ static char * parse_format(value fmt, /* Copy Caml format fmt to format_string, adding the suffix before the last letter of the format */ - len = string_length(fmt); + len = caml_string_length(fmt); len_suffix = strlen(suffix); if (len + len_suffix + 1 >= FORMAT_BUFFER_SIZE) - invalid_argument("format_int: format too long"); + caml_invalid_argument("format_int: format too long"); memmove(format_string, String_val(fmt), len); p = format_string + len - 1; lastletter = *p; @@ -148,10 +165,10 @@ static char * parse_format(value fmt, if (prec < FORMAT_BUFFER_SIZE) return default_format_buffer; else - return stat_alloc(prec + 1); + return caml_stat_alloc(prec + 1); } -CAMLprim value format_int(value fmt, value arg) +CAMLprim value caml_format_int(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; char default_format_buffer[FORMAT_BUFFER_SIZE]; @@ -168,8 +185,8 @@ CAMLprim value format_int(value fmt, value arg) sprintf(buffer, format_string, Long_val(arg)); break; } - res = copy_string(buffer); - if (buffer != default_format_buffer) stat_free(buffer); + res = caml_copy_string(buffer); + if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } @@ -190,17 +207,17 @@ static long int32_hash(value v) static void int32_serialize(value v, unsigned long * wsize_32, unsigned long * wsize_64) { - serialize_int_4(Int32_val(v)); + caml_serialize_int_4(Int32_val(v)); *wsize_32 = *wsize_64 = 4; } static unsigned long int32_deserialize(void * dst) { - *((int32 *) dst) = deserialize_sint_4(); + *((int32 *) dst) = caml_deserialize_sint_4(); return 4; } -CAMLexport struct custom_operations int32_ops = { +CAMLexport struct custom_operations caml_int32_ops = { "_i", custom_finalize_default, int32_cmp, @@ -209,78 +226,78 @@ CAMLexport struct custom_operations int32_ops = { int32_deserialize }; -CAMLexport value copy_int32(int32 i) +CAMLexport value caml_copy_int32(int32 i) { - value res = alloc_custom(&int32_ops, 4, 0, 1); + value res = caml_alloc_custom(&caml_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 caml_int32_neg(value v) +{ return caml_copy_int32(- Int32_val(v)); } -CAMLprim value int32_add(value v1, value v2) -{ return copy_int32(Int32_val(v1) + Int32_val(v2)); } +CAMLprim value caml_int32_add(value v1, value v2) +{ return caml_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 caml_int32_sub(value v1, value v2) +{ return caml_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 caml_int32_mul(value v1, value v2) +{ return caml_copy_int32(Int32_val(v1) * Int32_val(v2)); } -CAMLprim value int32_div(value v1, value v2) +CAMLprim value caml_int32_div(value v1, value v2) { int32 divisor = Int32_val(v2); - if (divisor == 0) raise_zero_divide(); + if (divisor == 0) caml_raise_zero_divide(); #ifdef NONSTANDARD_DIV_MOD - return copy_int32(caml_safe_div(Int32_val(v1), divisor)); + return caml_copy_int32(caml_safe_div(Int32_val(v1), divisor)); #else - return copy_int32(Int32_val(v1) / divisor); + return caml_copy_int32(Int32_val(v1) / divisor); #endif } -CAMLprim value int32_mod(value v1, value v2) +CAMLprim value caml_int32_mod(value v1, value v2) { int32 divisor = Int32_val(v2); - if (divisor == 0) raise_zero_divide(); + if (divisor == 0) caml_raise_zero_divide(); #ifdef NONSTANDARD_DIV_MOD - return copy_int32(caml_safe_mod(Int32_val(v1), divisor)); + return caml_copy_int32(caml_safe_mod(Int32_val(v1), divisor)); #else - return copy_int32(Int32_val(v1) % divisor); + return caml_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 caml_int32_and(value v1, value v2) +{ return caml_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 caml_int32_or(value v1, value v2) +{ return caml_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 caml_int32_xor(value v1, value v2) +{ return caml_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 caml_int32_shift_left(value v1, value v2) +{ return caml_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 caml_int32_shift_right(value v1, value v2) +{ return caml_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 caml_int32_shift_right_unsigned(value v1, value v2) +{ return caml_copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); } -CAMLprim value int32_of_int(value v) -{ return copy_int32(Long_val(v)); } +CAMLprim value caml_int32_of_int(value v) +{ return caml_copy_int32(Long_val(v)); } -CAMLprim value int32_to_int(value v) +CAMLprim value caml_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 caml_int32_of_float(value v) +{ return caml_copy_int32((int32)(Double_val(v))); } -CAMLprim value int32_to_float(value v) -{ return copy_double((double)(Int32_val(v))); } +CAMLprim value caml_int32_to_float(value v) +{ return caml_copy_double((double)(Int32_val(v))); } -CAMLprim value int32_compare(value v1, value v2) +CAMLprim value caml_int32_compare(value v1, value v2) { int32 i1 = Int32_val(v1); int32 i2 = Int32_val(v2); @@ -288,7 +305,7 @@ CAMLprim value int32_compare(value v1, value v2) return Val_int(res); } -CAMLprim value int32_format(value fmt, value arg) +CAMLprim value caml_int32_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; char default_format_buffer[FORMAT_BUFFER_SIZE]; @@ -298,14 +315,28 @@ CAMLprim value int32_format(value fmt, value arg) 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); + res = caml_copy_string(buffer); + if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } -CAMLprim value int32_of_string(value s) +CAMLprim value caml_int32_of_string(value s) { - return copy_int32(parse_long(s)); + return caml_copy_int32(parse_long(s, 32)); +} + +CAMLprim value caml_int32_bits_of_float(value vd) +{ + union { float d; int32 i; } u; + u.d = Double_val(vd); + return caml_copy_int32(u.i); +} + +CAMLprim value caml_int32_float_of_bits(value vi) +{ + union { float d; int32 i; } u; + u.i = Int32_val(vi); + return caml_copy_double(u.d); } /* 64-bit integers */ @@ -318,7 +349,7 @@ CAMLprim value int32_of_string(value s) #ifdef ARCH_ALIGN_INT64 -CAMLexport int64 Int64_val(value v) +CAMLexport int64 caml_Int64_val(value v) { union { int32 i[2]; int64 j; } buffer; buffer.i[0] = ((int32 *) Data_custom_val(v))[0]; @@ -343,24 +374,24 @@ static long int64_hash(value v) static void int64_serialize(value v, unsigned long * wsize_32, unsigned long * wsize_64) { - serialize_int_8(Int64_val(v)); + caml_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(); + *((int64 *) dst) = caml_deserialize_sint_8(); #else union { int32 i[2]; int64 j; } buffer; - buffer.j = deserialize_sint_8(); + buffer.j = caml_deserialize_sint_8(); ((int32 *) dst)[0] = buffer.i[0]; ((int32 *) dst)[1] = buffer.i[1]; #endif return 8; } -CAMLexport struct custom_operations int64_ops = { +CAMLexport struct custom_operations caml_int64_ops = { "_j", custom_finalize_default, int64_cmp, @@ -369,9 +400,9 @@ CAMLexport struct custom_operations int64_ops = { int64_deserialize }; -CAMLexport value copy_int64(int64 i) +CAMLexport value caml_copy_int64(int64 i) { - value res = alloc_custom(&int64_ops, 8, 0, 1); + value res = caml_alloc_custom(&caml_int64_ops, 8, 0, 1); #ifndef ARCH_ALIGN_INT64 Int64_val(res) = i; #else @@ -383,78 +414,78 @@ CAMLexport value copy_int64(int64 i) return res; } -CAMLprim value int64_neg(value v) -{ return copy_int64(I64_neg(Int64_val(v))); } +CAMLprim value caml_int64_neg(value v) +{ return caml_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 caml_int64_add(value v1, value v2) +{ return caml_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 caml_int64_sub(value v1, value v2) +{ return caml_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 caml_int64_mul(value v1, value v2) +{ return caml_copy_int64(I64_mul(Int64_val(v1), Int64_val(v2))); } -CAMLprim value int64_div(value v1, value v2) +CAMLprim value caml_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)); + if (I64_is_zero(divisor)) caml_raise_zero_divide(); + return caml_copy_int64(I64_div(Int64_val(v1), divisor)); } -CAMLprim value int64_mod(value v1, value v2) +CAMLprim value caml_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)); + if (I64_is_zero(divisor)) caml_raise_zero_divide(); + return caml_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 caml_int64_and(value v1, value v2) +{ return caml_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 caml_int64_or(value v1, value v2) +{ return caml_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 caml_int64_xor(value v1, value v2) +{ return caml_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 caml_int64_shift_left(value v1, value v2) +{ return caml_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 caml_int64_shift_right(value v1, value v2) +{ return caml_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 caml_int64_shift_right_unsigned(value v1, value v2) +{ return caml_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 caml_int64_of_int(value v) +{ return caml_copy_int64(I64_of_long(Long_val(v))); } -CAMLprim value int64_to_int(value v) +CAMLprim value caml_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 caml_int64_of_float(value v) +{ return caml_copy_int64(I64_of_double(Double_val(v))); } -CAMLprim value int64_to_float(value v) +CAMLprim value caml_int64_to_float(value v) { int64 i = Int64_val(v); - return copy_double(I64_to_double(i)); + return caml_copy_double(I64_to_double(i)); } -CAMLprim value int64_of_int32(value v) -{ return copy_int64(I64_of_int32(Int32_val(v))); } +CAMLprim value caml_int64_of_int32(value v) +{ return caml_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 caml_int64_to_int32(value v) +{ return caml_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 caml_int64_of_nativeint(value v) +{ return caml_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 caml_int64_to_nativeint(value v) +{ return caml_copy_nativeint(I64_to_long(Int64_val(v))); } -CAMLprim value int64_compare(value v1, value v2) +CAMLprim value caml_int64_compare(value v1, value v2) { int64 i1 = Int64_val(v1); int64 i2 = Int64_val(v2); @@ -468,7 +499,7 @@ CAMLprim value int64_compare(value v1, value v2) #define ARCH_INT64_PRINTF_FORMAT "" #endif -CAMLprim value int64_format(value fmt, value arg) +CAMLprim value caml_int64_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; char default_format_buffer[FORMAT_BUFFER_SIZE]; @@ -479,45 +510,55 @@ CAMLprim value int64_format(value fmt, value arg) 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); + res = caml_copy_string(buffer); + if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } -CAMLprim value int64_of_string(value s) +CAMLprim value caml_int64_of_string(value s) { char * p; - int64 res; + uint64 max_uint64 = I64_literal(0xFFFFFFFF, 0xFFFFFFFF); + uint64 max_int64 = I64_literal(0x80000000, 0x00000000); + uint64 res, threshold; int sign, base, d; p = parse_sign_and_base(String_val(s), &base, &sign); + I64_udivmod(max_uint64, I64_of_int32(base), &threshold, &res); d = parse_digit(*p); - if (d < 0 || d >= base) failwith("int_of_string"); + if (d < 0 || d >= base) caml_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; + /* Detect overflow in multiplication base * res */ + if (I64_ult(threshold, res)) caml_failwith("int_of_string"); res = I64_add(I64_mul(I64_of_int32(base), res), I64_of_int32(d)); + /* Detect overflow in addition (base * res) + d */ + if (I64_ult(res, I64_of_int32(d))) caml_failwith("int_of_string"); } - if (p != String_val(s) + string_length(s)) failwith("int_of_string"); + if (p != String_val(s) + caml_string_length(s)){ + caml_failwith("int_of_string"); + } + if (base == 10 && I64_ult(max_int64, res)) caml_failwith("int_of_string"); if (sign < 0) res = I64_neg(res); - return copy_int64(res); + return caml_copy_int64(res); } -CAMLprim value int64_bits_of_float(value vd) +CAMLprim value caml_int64_bits_of_float(value vd) { union { double d; int64 i; } u; u.d = Double_val(vd); - return copy_int64(u.i); + return caml_copy_int64(u.i); } -CAMLprim value int64_float_of_bits(value vi) +CAMLprim value caml_int64_float_of_bits(value vi) { union { double d; int64 i; } u; u.i = Int64_val(vi); - return copy_double(u.d); + return caml_copy_double(u.d); } /* Native integers */ @@ -540,15 +581,15 @@ static void nativeint_serialize(value v, unsigned long * wsize_32, long l = Nativeint_val(v); #ifdef ARCH_SIXTYFOUR if (l <= 0x7FFFFFFFL && l >= -0x80000000L) { - serialize_int_1(1); - serialize_int_4((int32) l); + caml_serialize_int_1(1); + caml_serialize_int_4((int32) l); } else { - serialize_int_1(2); - serialize_int_8(l); + caml_serialize_int_1(2); + caml_serialize_int_8(l); } #else - serialize_int_1(1); - serialize_int_4(l); + caml_serialize_int_1(1); + caml_serialize_int_4(l); #endif *wsize_32 = 4; *wsize_64 = 8; @@ -556,24 +597,24 @@ static void nativeint_serialize(value v, unsigned long * wsize_32, static unsigned long nativeint_deserialize(void * dst) { - switch (deserialize_uint_1()) { + switch (caml_deserialize_uint_1()) { case 1: - *((long *) dst) = deserialize_sint_4(); + *((long *) dst) = caml_deserialize_sint_4(); break; case 2: #ifdef ARCH_SIXTYFOUR - *((long *) dst) = deserialize_sint_8(); + *((long *) dst) = caml_deserialize_sint_8(); #else - deserialize_error("input_value: native integer value too large"); + caml_deserialize_error("input_value: native integer value too large"); #endif break; default: - deserialize_error("input_value: ill-formed native integer"); + caml_deserialize_error("input_value: ill-formed native integer"); } return sizeof(long); } -CAMLexport struct custom_operations nativeint_ops = { +CAMLexport struct custom_operations caml_nativeint_ops = { "_n", custom_finalize_default, nativeint_cmp, @@ -582,84 +623,84 @@ CAMLexport struct custom_operations nativeint_ops = { nativeint_deserialize }; -CAMLexport value copy_nativeint(long i) +CAMLexport value caml_copy_nativeint(long i) { - value res = alloc_custom(&nativeint_ops, sizeof(long), 0, 1); + value res = caml_alloc_custom(&caml_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 caml_nativeint_neg(value v) +{ return caml_copy_nativeint(- Nativeint_val(v)); } -CAMLprim value nativeint_add(value v1, value v2) -{ return copy_nativeint(Nativeint_val(v1) + Nativeint_val(v2)); } +CAMLprim value caml_nativeint_add(value v1, value v2) +{ return caml_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 caml_nativeint_sub(value v1, value v2) +{ return caml_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 caml_nativeint_mul(value v1, value v2) +{ return caml_copy_nativeint(Nativeint_val(v1) * Nativeint_val(v2)); } -CAMLprim value nativeint_div(value v1, value v2) +CAMLprim value caml_nativeint_div(value v1, value v2) { long divisor = Nativeint_val(v2); - if (divisor == 0) raise_zero_divide(); + if (divisor == 0) caml_raise_zero_divide(); #ifdef NONSTANDARD_DIV_MOD - return copy_nativeint(caml_safe_div(Nativeint_val(v1), divisor)); + return caml_copy_nativeint(caml_safe_div(Nativeint_val(v1), divisor)); #else - return copy_nativeint(Nativeint_val(v1) / divisor); + return caml_copy_nativeint(Nativeint_val(v1) / divisor); #endif } -CAMLprim value nativeint_mod(value v1, value v2) +CAMLprim value caml_nativeint_mod(value v1, value v2) { long divisor = Nativeint_val(v2); - if (divisor == 0) raise_zero_divide(); + if (divisor == 0) caml_raise_zero_divide(); #ifdef NONSTANDARD_DIV_MOD - return copy_nativeint(caml_safe_mod(Nativeint_val(v1), divisor)); + return caml_copy_nativeint(caml_safe_mod(Nativeint_val(v1), divisor)); #else - return copy_nativeint(Nativeint_val(v1) % divisor); + return caml_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 caml_nativeint_and(value v1, value v2) +{ return caml_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 caml_nativeint_or(value v1, value v2) +{ return caml_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 caml_nativeint_xor(value v1, value v2) +{ return caml_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 caml_nativeint_shift_left(value v1, value v2) +{ return caml_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 caml_nativeint_shift_right(value v1, value v2) +{ return caml_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 caml_nativeint_shift_right_unsigned(value v1, value v2) +{ return caml_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 caml_nativeint_of_int(value v) +{ return caml_copy_nativeint(Long_val(v)); } -CAMLprim value nativeint_to_int(value v) +CAMLprim value caml_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 caml_nativeint_of_float(value v) +{ return caml_copy_nativeint((long)(Double_val(v))); } -CAMLprim value nativeint_to_float(value v) -{ return copy_double((double)(Nativeint_val(v))); } +CAMLprim value caml_nativeint_to_float(value v) +{ return caml_copy_double((double)(Nativeint_val(v))); } -CAMLprim value nativeint_of_int32(value v) -{ return copy_nativeint(Int32_val(v)); } +CAMLprim value caml_nativeint_of_int32(value v) +{ return caml_copy_nativeint(Int32_val(v)); } -CAMLprim value nativeint_to_int32(value v) -{ return copy_int32(Nativeint_val(v)); } +CAMLprim value caml_nativeint_to_int32(value v) +{ return caml_copy_int32(Nativeint_val(v)); } -CAMLprim value nativeint_compare(value v1, value v2) +CAMLprim value caml_nativeint_compare(value v1, value v2) { long i1 = Nativeint_val(v1); long i2 = Nativeint_val(v2); @@ -667,7 +708,7 @@ CAMLprim value nativeint_compare(value v1, value v2) return Val_int(res); } -CAMLprim value nativeint_format(value fmt, value arg) +CAMLprim value caml_nativeint_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; char default_format_buffer[FORMAT_BUFFER_SIZE]; @@ -677,14 +718,12 @@ CAMLprim value nativeint_format(value fmt, value arg) 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); + res = caml_copy_string(buffer); + if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } -CAMLprim value nativeint_of_string(value s) +CAMLprim value caml_nativeint_of_string(value s) { - return copy_nativeint(parse_long(s)); + return caml_copy_nativeint(parse_long(s, 8 * sizeof(value))); } - - diff --git a/byterun/io.c b/byterun/io.c index d3ce9091..4e0e4b56 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: io.c,v 1.63 2003/07/29 11:48:34 xleroy Exp $ */ +/* $Id: io.c,v 1.68 2004/01/08 22:28:48 doligez Exp $ */ /* Buffered input/output. */ @@ -19,9 +19,7 @@ #include #include #include -#if !macintosh #include -#endif #include "config.h" #ifdef HAS_UNISTD #include @@ -35,9 +33,6 @@ #include "mlvalues.h" #include "signals.h" #include "sys.h" -#ifdef HAS_UI -#include "ui.h" -#endif #ifndef SEEK_SET #define SEEK_SET 0 @@ -47,13 +42,13 @@ /* 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; +CAMLexport void (*caml_channel_mutex_free) (struct channel *) = NULL; +CAMLexport void (*caml_channel_mutex_lock) (struct channel *) = NULL; +CAMLexport void (*caml_channel_mutex_unlock) (struct channel *) = NULL; +CAMLexport void (*caml_channel_mutex_unlock_exn) (void) = NULL; /* List of opened channels */ -CAMLexport struct channel * all_opened_channels = NULL; +CAMLexport struct channel * caml_all_opened_channels = NULL; /* Basic functions over type struct channel *. These functions can be called directly from C. @@ -61,11 +56,11 @@ CAMLexport struct channel * all_opened_channels = NULL; /* Functions shared between input and output */ -CAMLexport struct channel * open_descriptor_in(int fd) +CAMLexport struct channel * caml_open_descriptor_in(int fd) { struct channel * channel; - channel = (struct channel *) stat_alloc(sizeof(struct channel)); + channel = (struct channel *) caml_stat_alloc(sizeof(struct channel)); channel->fd = fd; channel->offset = lseek (fd, 0, SEEK_CUR); channel->curr = channel->max = channel->buff; @@ -74,23 +69,23 @@ CAMLexport struct channel * open_descriptor_in(int fd) channel->revealed = 0; channel->old_revealed = 0; channel->refcount = 0; - channel->next = all_opened_channels; - all_opened_channels = channel; + channel->next = caml_all_opened_channels; + caml_all_opened_channels = channel; return channel; } -CAMLexport struct channel * open_descriptor_out(int fd) +CAMLexport struct channel * caml_open_descriptor_out(int fd) { struct channel * channel; - channel = open_descriptor_in(fd); + channel = caml_open_descriptor_in(fd); channel->max = NULL; return channel; } static void unlink_channel(struct channel *channel) { - struct channel ** cp = &all_opened_channels; + struct channel ** cp = &caml_all_opened_channels; while (*cp != channel && *cp != NULL) cp = &(*cp)->next; @@ -98,28 +93,28 @@ static void unlink_channel(struct channel *channel) *cp = (*cp)->next; } -CAMLexport void close_channel(struct channel *channel) +CAMLexport void caml_close_channel(struct channel *channel) { close(channel->fd); if (channel->refcount > 0) return; - if (channel_mutex_free != NULL) (*channel_mutex_free)(channel); + if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel); unlink_channel(channel); - stat_free(channel); + caml_stat_free(channel); } -CAMLexport file_offset channel_size(struct channel *channel) +CAMLexport file_offset caml_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); + caml_sys_error(NO_ARG); } return end; } -CAMLexport int channel_binary_mode(struct channel *channel) +CAMLexport int caml_channel_binary_mode(struct channel *channel) { #ifdef _WIN32 int oldmode = setmode(channel->fd, O_BINARY); @@ -147,13 +142,10 @@ 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(); + caml_enter_blocking_section(); retcode = write(fd, p, n); - leave_blocking_section(); + caml_leave_blocking_section(); if (retcode == -1) { if (errno == EINTR) goto again; if ((errno == EAGAIN || errno == EWOULDBLOCK) && n > 1) { @@ -165,8 +157,7 @@ again: n = 1; goto again; } } -#endif - if (retcode == -1) sys_error(NO_ARG); + if (retcode == -1) caml_sys_error(NO_ARG); return retcode; } @@ -175,7 +166,7 @@ again: end of the flush, or false if some data remains in the buffer. */ -CAMLexport int flush_partial(struct channel *channel) +CAMLexport int caml_flush_partial(struct channel *channel) { int towrite, written; @@ -192,24 +183,24 @@ CAMLexport int flush_partial(struct channel *channel) /* Flush completely the buffer. */ -CAMLexport void flush(struct channel *channel) +CAMLexport void caml_flush(struct channel *channel) { - while (! flush_partial(channel)) /*nothing*/; + while (! caml_flush_partial(channel)) /*nothing*/; } /* Output data */ -CAMLexport void putword(struct channel *channel, uint32 w) +CAMLexport void caml_putword(struct channel *channel, uint32 w) { - if (! channel_binary_mode(channel)) - failwith("output_binary_int: not a binary channel"); + if (! caml_channel_binary_mode(channel)) + caml_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) +CAMLexport int caml_putblock(struct channel *channel, char *p, long int len) { int n, free, towrite, written; @@ -234,70 +225,66 @@ CAMLexport int putblock(struct channel *channel, char *p, long int len) } } -CAMLexport void really_putblock(struct channel *channel, char *p, long int len) +CAMLexport void caml_really_putblock(struct channel *channel, char *p, long len) { int written; while (len > 0) { - written = putblock(channel, p, len); + written = caml_putblock(channel, p, len); p += written; len -= written; } } -CAMLexport void seek_out(struct channel *channel, file_offset dest) +CAMLexport void caml_seek_out(struct channel *channel, file_offset dest) { - flush(channel); - if (lseek(channel->fd, dest, SEEK_SET) != dest) sys_error(NO_ARG); + caml_flush(channel); + if (lseek(channel->fd, dest, SEEK_SET) != dest) caml_sys_error(NO_ARG); channel->offset = dest; } -CAMLexport file_offset pos_out(struct channel *channel) +CAMLexport file_offset caml_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) +/* caml_do_read is exported for Cash */ +CAMLexport int caml_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 + caml_enter_blocking_section(); #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); + caml_leave_blocking_section(); + if (retcode == -1) caml_sys_error(NO_ARG); return retcode; } -CAMLexport unsigned char refill(struct channel *channel) +CAMLexport unsigned char caml_refill(struct channel *channel) { int n; - n = do_read(channel->fd, channel->buff, channel->end - channel->buff); - if (n == 0) raise_end_of_file(); + n = caml_do_read(channel->fd, channel->buff, channel->end - channel->buff); + if (n == 0) caml_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) +CAMLexport uint32 caml_getword(struct channel *channel) { int i; uint32 res; - if (! channel_binary_mode(channel)) - failwith("input_binary_int: not a binary channel"); + if (! caml_channel_binary_mode(channel)) + caml_failwith("input_binary_int: not a binary channel"); res = 0; for(i = 0; i < 4; i++) { res = (res << 8) + getch(channel); @@ -305,7 +292,7 @@ CAMLexport uint32 getword(struct channel *channel) return res; } -CAMLexport int getblock(struct channel *channel, char *p, long int len) +CAMLexport int caml_getblock(struct channel *channel, char *p, long int len) { int n, avail, nread; @@ -320,7 +307,8 @@ CAMLexport int getblock(struct channel *channel, char *p, long int len) channel->curr += avail; return avail; } else { - nread = do_read(channel->fd, channel->buff, channel->end - channel->buff); + nread = caml_do_read(channel->fd, channel->buff, + channel->end - channel->buff); channel->offset += nread; channel->max = channel->buff + nread; if (n > nread) n = nread; @@ -330,11 +318,11 @@ CAMLexport int getblock(struct channel *channel, char *p, long int len) } } -CAMLexport int really_getblock(struct channel *chan, char *p, long int n) +CAMLexport int caml_really_getblock(struct channel *chan, char *p, long int n) { int r; while (n > 0) { - r = getblock(chan, p, n); + r = caml_getblock(chan, p, n); if (r == 0) break; p += r; n -= r; @@ -342,24 +330,24 @@ CAMLexport int really_getblock(struct channel *chan, char *p, long int n) return (n == 0); } -CAMLexport void seek_in(struct channel *channel, file_offset dest) +CAMLexport void caml_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); + if (lseek(channel->fd, dest, SEEK_SET) != dest) caml_sys_error(NO_ARG); channel->offset = dest; channel->curr = channel->max = channel->buff; } } -CAMLexport file_offset pos_in(struct channel *channel) +CAMLexport file_offset caml_pos_in(struct channel *channel) { return channel->offset - (file_offset)(channel->max - channel->curr); } -CAMLexport long input_scan_line(struct channel *channel) +CAMLexport long caml_input_scan_line(struct channel *channel) { char * p; int n; @@ -384,7 +372,7 @@ CAMLexport long input_scan_line(struct channel *channel) return -(channel->max - channel->curr); } /* Fill the buffer as much as possible */ - n = do_read(channel->fd, channel->max, channel->end - channel->max); + n = caml_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 @@ -402,14 +390,14 @@ CAMLexport long input_scan_line(struct channel *channel) /* 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) +/* FIXME CAMLexport, but not in io.h exported for Cash ? */ +CAMLexport void caml_finalize_channel(value vchan) { struct channel * chan = Channel(vchan); if (--chan->refcount > 0) return; - if (channel_mutex_free != NULL) (*channel_mutex_free)(chan); + if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(chan); unlink_channel(chan); - stat_free(chan); + caml_stat_free(chan); } static int compare_channel(value vchan1, value vchan2) @@ -421,64 +409,65 @@ static int compare_channel(value vchan1, value vchan2) static struct custom_operations channel_operations = { "_chan", - finalize_channel, + caml_finalize_channel, compare_channel, custom_hash_default, custom_serialize_default, custom_deserialize_default }; -CAMLexport value alloc_channel(struct channel *chan) +CAMLexport value caml_alloc_channel(struct channel *chan) { value res; chan->refcount++; /* prevent finalization during next alloc */ - res = alloc_custom(&channel_operations, sizeof(struct channel *), 1, 1000); + res = caml_alloc_custom(&channel_operations, sizeof(struct channel *), + 1, 1000); Channel(res) = chan; return res; } -CAMLprim value caml_open_descriptor_in(value fd) +CAMLprim value caml_ml_open_descriptor_in(value fd) { - return alloc_channel(open_descriptor_in(Int_val(fd))); + return caml_alloc_channel(caml_open_descriptor_in(Int_val(fd))); } -CAMLprim value caml_open_descriptor_out(value fd) +CAMLprim value caml_ml_open_descriptor_out(value fd) { - return alloc_channel(open_descriptor_out(Int_val(fd))); + return caml_alloc_channel(caml_open_descriptor_out(Int_val(fd))); } #define Pair_tag 0 -CAMLprim value caml_out_channels_list (value unit) +CAMLprim value caml_ml_out_channels_list (value unit) { CAMLparam0 (); CAMLlocal3 (res, tail, chan); struct channel * channel; res = Val_emptylist; - for (channel = all_opened_channels; + for (channel = caml_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. */ + caml_ml_close_channel changes max when setting fd to -1. */ if (channel->max == NULL) { - chan = alloc_channel (channel); + chan = caml_alloc_channel (channel); tail = res; - res = alloc_small (2, Pair_tag); + res = caml_alloc_small (2, Pair_tag); Field (res, 0) = chan; Field (res, 1) = tail; } CAMLreturn (res); } -CAMLprim value channel_descriptor(value vchannel) +CAMLprim value caml_channel_descriptor(value vchannel) { int fd = Channel(vchannel)->fd; - if (fd == -1) { errno = EBADF; sys_error(NO_ARG); } + if (fd == -1) { errno = EBADF; caml_sys_error(NO_ARG); } return Val_int(fd); } -CAMLprim value caml_close_channel(value vchannel) +CAMLprim value caml_ml_close_channel(value vchannel) { int result; @@ -491,10 +480,10 @@ CAMLprim value caml_close_channel(value vchannel) result = 0; } /* Ensure that every read or write on the channel will cause an - immediate flush_partial or refill, thus raising a Sys_error + immediate caml_flush_partial or caml_refill, thus raising a Sys_error exception */ channel->curr = channel->max = channel->end; - if (result == -1) sys_error (NO_ARG); + if (result == -1) caml_sys_error (NO_ARG); return Val_unit; } @@ -507,24 +496,24 @@ CAMLprim value caml_close_channel(value vchannel) #define EOVERFLOW ERANGE #endif -CAMLprim value caml_channel_size(value vchannel) +CAMLprim value caml_ml_channel_size(value vchannel) { - file_offset size = channel_size(Channel(vchannel)); - if (size > Max_long) { errno = EOVERFLOW; sys_error(NO_ARG); } + file_offset size = caml_channel_size(Channel(vchannel)); + if (size > Max_long) { errno = EOVERFLOW; caml_sys_error(NO_ARG); } return Val_long(size); } -CAMLprim value caml_channel_size_64(value vchannel) +CAMLprim value caml_ml_channel_size_64(value vchannel) { - return Val_file_offset(channel_size(Channel(vchannel))); + return Val_file_offset(caml_channel_size(Channel(vchannel))); } -CAMLprim value caml_set_binary_mode(value vchannel, value mode) +CAMLprim value caml_ml_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); + caml_sys_error(NO_ARG); #endif return Val_unit; } @@ -536,30 +525,30 @@ CAMLprim value caml_set_binary_mode(value vchannel, value mode) file descriptors that may be closed. */ -CAMLprim value caml_flush_partial(value vchannel) +CAMLprim value caml_ml_flush_partial(value vchannel) { struct channel * channel = Channel(vchannel); int res; if (channel->fd == -1) return Val_true; Lock(channel); - res = flush_partial(channel); + res = caml_flush_partial(channel); Unlock(channel); return Val_bool(res); } -CAMLprim value caml_flush(value vchannel) +CAMLprim value caml_ml_flush(value vchannel) { struct channel * channel = Channel(vchannel); if (channel->fd == -1) return Val_unit; Lock(channel); - flush(channel); + caml_flush(channel); Unlock(channel); return Val_unit; } -CAMLprim value caml_output_char(value vchannel, value ch) +CAMLprim value caml_ml_output_char(value vchannel, value ch) { struct channel * channel = Channel(vchannel); Lock(channel); @@ -568,28 +557,30 @@ CAMLprim value caml_output_char(value vchannel, value ch) return Val_unit; } -CAMLprim value caml_output_int(value vchannel, value w) +CAMLprim value caml_ml_output_int(value vchannel, value w) { struct channel * channel = Channel(vchannel); Lock(channel); - putword(channel, Long_val(w)); + caml_putword(channel, Long_val(w)); Unlock(channel); return Val_unit; } -CAMLprim value caml_output_partial(value vchannel, value buff, value start, value length) +CAMLprim value caml_ml_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)); + res = caml_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) +CAMLprim value caml_ml_output(value vchannel, value buff, value start, + value length) { CAMLparam4 (vchannel, buff, start, length); struct channel * channel = Channel(vchannel); @@ -598,7 +589,7 @@ CAMLprim value caml_output(value vchannel, value buff, value start, value length Lock(channel); while (len > 0) { - int written = putblock(channel, &Byte(buff, pos), len); + int written = caml_putblock(channel, &Byte(buff, pos), len); pos += written; len -= written; } @@ -606,37 +597,37 @@ CAMLprim value caml_output(value vchannel, value buff, value start, value length CAMLreturn (Val_unit); } -CAMLprim value caml_seek_out(value vchannel, value pos) +CAMLprim value caml_ml_seek_out(value vchannel, value pos) { struct channel * channel = Channel(vchannel); Lock(channel); - seek_out(channel, Long_val(pos)); + caml_seek_out(channel, Long_val(pos)); Unlock(channel); return Val_unit; } -CAMLprim value caml_seek_out_64(value vchannel, value pos) +CAMLprim value caml_ml_seek_out_64(value vchannel, value pos) { struct channel * channel = Channel(vchannel); Lock(channel); - seek_out(channel, File_offset_val(pos)); + caml_seek_out(channel, File_offset_val(pos)); Unlock(channel); return Val_unit; } -CAMLprim value caml_pos_out(value vchannel) +CAMLprim value caml_ml_pos_out(value vchannel) { - file_offset pos = pos_out(Channel(vchannel)); - if (pos > Max_long) { errno = EOVERFLOW; sys_error(NO_ARG); } + file_offset pos = caml_pos_out(Channel(vchannel)); + if (pos > Max_long) { errno = EOVERFLOW; caml_sys_error(NO_ARG); } return Val_long(pos); } -CAMLprim value caml_pos_out_64(value vchannel) +CAMLprim value caml_ml_pos_out_64(value vchannel) { - return Val_file_offset(pos_out(Channel(vchannel))); + return Val_file_offset(caml_pos_out(Channel(vchannel))); } -CAMLprim value caml_input_char(value vchannel) +CAMLprim value caml_ml_input_char(value vchannel) { struct channel * channel = Channel(vchannel); unsigned char c; @@ -647,13 +638,13 @@ CAMLprim value caml_input_char(value vchannel) return Val_long(c); } -CAMLprim value caml_input_int(value vchannel) +CAMLprim value caml_ml_input_int(value vchannel) { struct channel * channel = Channel(vchannel); long i; Lock(channel); - i = getword(channel); + i = caml_getword(channel); Unlock(channel); #ifdef ARCH_SIXTYFOUR i = (i << 32) >> 32; /* Force sign extension */ @@ -661,7 +652,8 @@ CAMLprim value caml_input_int(value vchannel) return Val_long(i); } -CAMLprim value caml_input(value vchannel,value buff,value vstart,value vlength) +CAMLprim value caml_ml_input(value vchannel, value buff, value vstart, + value vlength) { CAMLparam4 (vchannel, buff, vstart, vlength); struct channel * channel = Channel(vchannel); @@ -669,7 +661,8 @@ CAMLprim value caml_input(value vchannel,value buff,value vstart,value vlength) int n, avail, nread; Lock(channel); - /* We cannot call getblock here because buff may move during do_read */ + /* We cannot call caml_getblock here because buff may move during + caml_do_read */ start = Long_val(vstart); len = Long_val(vlength); n = len >= INT_MAX ? INT_MAX : (int) len; @@ -682,7 +675,8 @@ CAMLprim value caml_input(value vchannel,value buff,value vstart,value vlength) channel->curr += avail; n = avail; } else { - nread = do_read(channel->fd, channel->buff, channel->end - channel->buff); + nread = caml_do_read(channel->fd, channel->buff, + channel->end - channel->buff); channel->offset += nread; channel->max = channel->buff + nread; if (n > nread) n = nread; @@ -693,43 +687,43 @@ CAMLprim value caml_input(value vchannel,value buff,value vstart,value vlength) CAMLreturn (Val_long(n)); } -CAMLprim value caml_seek_in(value vchannel, value pos) +CAMLprim value caml_ml_seek_in(value vchannel, value pos) { struct channel * channel = Channel(vchannel); Lock(channel); - seek_in(channel, Long_val(pos)); + caml_seek_in(channel, Long_val(pos)); Unlock(channel); return Val_unit; } -CAMLprim value caml_seek_in_64(value vchannel, value pos) +CAMLprim value caml_ml_seek_in_64(value vchannel, value pos) { struct channel * channel = Channel(vchannel); Lock(channel); - seek_in(channel, File_offset_val(pos)); + caml_seek_in(channel, File_offset_val(pos)); Unlock(channel); return Val_unit; } -CAMLprim value caml_pos_in(value vchannel) +CAMLprim value caml_ml_pos_in(value vchannel) { - file_offset pos = pos_in(Channel(vchannel)); - if (pos > Max_long) { errno = EOVERFLOW; sys_error(NO_ARG); } + file_offset pos = caml_pos_in(Channel(vchannel)); + if (pos > Max_long) { errno = EOVERFLOW; caml_sys_error(NO_ARG); } return Val_long(pos); } -CAMLprim value caml_pos_in_64(value vchannel) +CAMLprim value caml_ml_pos_in_64(value vchannel) { - return Val_file_offset(pos_in(Channel(vchannel))); + return Val_file_offset(caml_pos_in(Channel(vchannel))); } -CAMLprim value caml_input_scan_line(value vchannel) +CAMLprim value caml_ml_input_scan_line(value vchannel) { struct channel * channel = Channel(vchannel); long res; Lock(channel); - res = input_scan_line(channel); + res = caml_input_scan_line(channel); Unlock(channel); return Val_long(res); } @@ -737,15 +731,15 @@ CAMLprim value caml_input_scan_line(value vchannel) /* Conversion between file_offset and int64 */ #ifndef ARCH_INT64_TYPE -CAMLexport value Val_file_offset(file_offset fofs) +CAMLexport value caml_Val_file_offset(file_offset fofs) { int64 ofs; ofs.l = fofs; ofs.h = 0; - return copy_int64(ofs); + return caml_copy_int64(ofs); } -CAMLexport file_offset File_offset_val(value v) +CAMLexport file_offset caml_File_offset_val(value v) { int64 ofs = Int64_val(v); return (file_offset) ofs.l; diff --git a/byterun/io.h b/byterun/io.h index f8b843dc..17719f34 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -11,12 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: io.h,v 1.22 2002/10/22 13:02:46 doligez Exp $ */ +/* $Id: io.h,v 1.25 2004/01/01 16:42:36 doligez Exp $ */ /* Buffered input/output */ -#ifndef _io_ -#define _io_ +#ifndef CAML_IO_H +#define CAML_IO_H #include "misc.h" #include "mlvalues.h" @@ -56,30 +56,30 @@ struct channel { type struct channel *. No locking is performed. */ #define putch(channel, ch) do{ \ - if ((channel)->curr >= (channel)->end) flush_partial(channel); \ + if ((channel)->curr >= (channel)->end) caml_flush_partial(channel); \ *((channel)->curr)++ = (ch); \ }while(0) #define getch(channel) \ ((channel)->curr >= (channel)->max \ - ? refill(channel) \ + ? caml_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 struct channel * caml_open_descriptor_in (int); +CAMLextern struct channel * caml_open_descriptor_out (int); +CAMLextern void caml_close_channel (struct channel *); +CAMLextern int caml_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 int caml_flush_partial (struct channel *); +CAMLextern void caml_flush (struct channel *); +CAMLextern void caml_putword (struct channel *, uint32); +CAMLextern int caml_putblock (struct channel *, char *, long); +CAMLextern void caml_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); +CAMLextern unsigned char caml_refill (struct channel *); +CAMLextern uint32 caml_getword (struct channel *); +CAMLextern int caml_getblock (struct channel *, char *, long); +CAMLextern int caml_really_getblock (struct channel *, char *, long); /* Extract a struct channel * from the heap object representing it */ @@ -87,26 +87,28 @@ CAMLextern int really_getblock (struct channel *, char *, long); /* 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); +CAMLextern void (*caml_channel_mutex_free) (struct channel *); +CAMLextern void (*caml_channel_mutex_lock) (struct channel *); +CAMLextern void (*caml_channel_mutex_unlock) (struct channel *); +CAMLextern void (*caml_channel_mutex_unlock_exn) (void); #define Lock(channel) \ - if (channel_mutex_lock != NULL) (*channel_mutex_lock)(channel) + if (caml_channel_mutex_lock != NULL) (*caml_channel_mutex_lock)(channel) #define Unlock(channel) \ - if (channel_mutex_unlock != NULL) (*channel_mutex_unlock)(channel) + if (caml_channel_mutex_unlock != NULL) (*caml_channel_mutex_unlock)(channel) #define Unlock_exn() \ - if (channel_mutex_unlock_exn != NULL) (*channel_mutex_unlock_exn)() + if (caml_channel_mutex_unlock_exn != NULL) (*caml_channel_mutex_unlock_exn)() /* Conversion between file_offset and int64 */ #ifdef ARCH_INT64_TYPE -#define Val_file_offset(fofs) copy_int64(fofs) +#define Val_file_offset(fofs) caml_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); +CAMLextern value caml_Val_file_offset(file_offset fofs); +CAMLextern file_offset caml_File_offset_val(value v); +#define Val_file_offset caml_Val_file_offset +#define File_offset_val caml_File_offset_val #endif -#endif /* _io_ */ +#endif /* CAML_IO_H */ diff --git a/byterun/lexing.c b/byterun/lexing.c index 26eea10b..db134f52 100644 --- a/byterun/lexing.c +++ b/byterun/lexing.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: lexing.c,v 1.25 2002/12/16 16:42:13 doligez Exp $ */ +/* $Id: lexing.c,v 1.27 2004/01/01 16:42:36 doligez Exp $ */ /* The table-driven automaton for lexers generated by camllex. */ @@ -56,8 +56,8 @@ struct lexing_table { #define Short(tbl,n) (((short *)(tbl))[(n)]) #endif -CAMLprim value lex_engine(struct lexing_table *tbl, value start_state, - struct lexer_buffer *lexbuf) +CAMLprim value caml_lex_engine(struct lexing_table *tbl, value start_state, + struct lexer_buffer *lexbuf) { int state, base, backtrk, c; @@ -101,7 +101,7 @@ CAMLprim value lex_engine(struct lexing_table *tbl, value start_state, if (state < 0) { lexbuf->lex_curr_pos = lexbuf->lex_last_pos; if (lexbuf->lex_last_action == Val_int(-1)) { - failwith("lexing: empty token"); + caml_failwith("lexing: empty token"); } else { return lexbuf->lex_last_action; } @@ -154,8 +154,8 @@ static void run_tag(char *pc, value mem) { } } -CAMLprim value new_lex_engine(struct lexing_table *tbl, value start_state, - struct lexer_buffer *lexbuf) +CAMLprim value caml_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); @@ -207,7 +207,7 @@ CAMLprim value new_lex_engine(struct lexing_table *tbl, value start_state, if (state < 0) { lexbuf->lex_curr_pos = lexbuf->lex_last_pos; if (lexbuf->lex_last_action == Val_int(-1)) { - failwith("lexing: empty token"); + caml_failwith("lexing: empty token"); } else { return lexbuf->lex_last_action; } diff --git a/byterun/macintosh.c b/byterun/macintosh.c deleted file mode 100644 index 6c2da406..00000000 --- a/byterun/macintosh.c +++ /dev/null @@ -1,319 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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/main.c b/byterun/main.c index 2ca175f9..6ede2d3f 100644 --- a/byterun/main.c +++ b/byterun/main.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: main.c,v 1.33 2002/06/07 09:49:37 xleroy Exp $ */ +/* $Id: main.c,v 1.36 2004/01/08 22:28:48 doligez Exp $ */ /* Main entry point (can be overridden by a user-provided main() function that calls caml_main() later). */ @@ -23,24 +23,16 @@ CAMLextern void caml_main (char **); #ifdef _WIN32 -CAMLextern void expand_command_line (int *, char ***); -#endif - -#if macintosh -#include "rotatecursor.h" -#include "signals.h" +CAMLextern void caml_expand_command_line (int *, char ***); #endif int main(int argc, char **argv) { #ifdef _WIN32 /* Expand wildcards and diversions in command line */ - expand_command_line(&argc, &argv); + caml_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)); + caml_sys_exit(Val_int(0)); return 0; /* not reached */ } diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 715f4497..4b715a0e 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.c,v 1.45 2002/12/15 23:27:06 doligez Exp $ */ +/* $Id: major_gc.c,v 1.54.2.1 2004/07/03 10:00:59 doligez Exp $ */ #include @@ -29,23 +29,24 @@ #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 */ +unsigned long caml_percent_free; +long caml_major_heap_increment; +CAMLexport char *caml_heap_start, *caml_heap_end; +CAMLexport page_table_entry *caml_page_table; +asize_t caml_page_low, caml_page_high; +char *caml_gc_sweep_hp; +int caml_gc_phase; /* always Phase_mark, Phase_sweep, or Phase_idle */ static value *gray_vals; -value *gray_vals_cur, *gray_vals_end; +static 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; +unsigned long caml_allocated_words; +unsigned long caml_dependent_size, caml_dependent_allocated; +double caml_extra_heap_resources; +unsigned long caml_fl_size_at_phase_change = 0; -extern char *fl_merge; /* Defined in freelist.c. */ +extern char *caml_fl_merge; /* Defined in freelist.c. */ static char *markhp, *chunk, *limit; @@ -60,13 +61,13 @@ 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); + if (gray_vals_size < caml_stat_heap_size / 128){ + caml_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); + caml_gc_message (0x08, "No room for growing gray_vals\n", 0); gray_vals_cur = gray_vals; heap_is_pure = 0; }else{ @@ -81,10 +82,11 @@ static void realloc_gray_vals (void) } } -void darken (value v, value *p /* not used */) +void caml_darken (value v, value *p /* not used */) { if (Is_block (v) && Is_in_heap (v)) { if (Tag_val(v) == Infix_tag) v -= Infix_offset_val(v); + CAMLassert (!Is_blue_val (v)); if (Is_white_val (v)){ Hd_val (v) = Grayhd_hd (Hd_val (v)); *gray_vals_cur++ = v; @@ -95,15 +97,15 @@ void darken (value v, value *p /* not used */) static void start_cycle (void) { - Assert (gc_phase == Phase_idle); + Assert (caml_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; + caml_gc_message (0x01, "Starting new major GC cycle\n", 0); + caml_darken_all_roots(); + caml_gc_phase = Phase_mark; gc_subphase = Subphase_main; markhp = NULL; #ifdef DEBUG - heap_check (); + caml_heap_check (); #endif } @@ -114,7 +116,7 @@ static void mark_slice (long work) header_t hd; mlsize_t size, i; - gc_message (0x40, "Marking %ld words\n", work); + caml_gc_message (0x40, "Marking %ld words\n", work); gray_vals_ptr = gray_vals_cur; while (work > 0){ if (gray_vals_ptr > gray_vals){ @@ -131,7 +133,8 @@ static void mark_slice (long work) 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)){ + && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag + || Tag_val (f) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ Field (v, i) = f; @@ -172,14 +175,14 @@ static void mark_slice (long work) } }else if (!heap_is_pure){ heap_is_pure = 1; - chunk = heap_start; + chunk = caml_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; + weak_prev = &caml_weak_list_head; }else if (gc_subphase == Subphase_weak){ value cur, curfield; mlsize_t sz, i; @@ -196,11 +199,13 @@ static void mark_slice (long work) for (i = 1; i < sz; i++){ curfield = Field (cur, i); weak_again: - if (curfield != 0 && Is_block (curfield) && Is_in_heap (curfield)){ + if (curfield != caml_weak_none + && 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){ + if (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag + || Tag_val (f) == Double_tag){ /* Do not short-circuit the pointer. */ }else{ Field (cur, i) = curfield = f; @@ -209,7 +214,7 @@ static void mark_slice (long work) } } if (Is_white_val (curfield)){ - Field (cur, i) = 0; + Field (cur, i) = caml_weak_none; } } } @@ -219,7 +224,7 @@ static void mark_slice (long work) }else{ /* Subphase_weak is done. Handle finalised values. */ gray_vals_cur = gray_vals_ptr; - final_update (); + caml_final_update (); gray_vals_ptr = gray_vals_cur; gc_subphase = Subphase_final; } @@ -227,14 +232,14 @@ static void mark_slice (long work) 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; + caml_gc_sweep_hp = caml_heap_start; + caml_fl_init_merge (); + caml_gc_phase = Phase_sweep; + chunk = caml_heap_start; + caml_gc_sweep_hp = chunk; limit = chunk + Chunk_size (chunk); work = 0; - fl_size_at_phase_change = fl_cur_size; + caml_fl_size_at_phase_change = caml_fl_cur_size; } } gray_vals_cur = gray_vals_ptr; @@ -245,40 +250,40 @@ static void sweep_slice (long work) char *hp; header_t hd; - gc_message (0x40, "Sweeping %ld words\n", work); + caml_gc_message (0x40, "Sweeping %ld words\n", work); while (work > 0){ - if (gc_sweep_hp < limit){ - hp = gc_sweep_hp; + if (caml_gc_sweep_hp < limit){ + hp = caml_gc_sweep_hp; hd = Hd_hp (hp); work -= Whsize_hd (hd); - gc_sweep_hp += Bhsize_hd (hd); + caml_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)); + caml_gc_sweep_hp = caml_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); + caml_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); + Assert (caml_gc_sweep_hp <= limit); }else{ chunk = Chunk_next (chunk); if (chunk == NULL){ /* Sweeping is done. */ - ++ stat_major_collections; + ++ caml_stat_major_collections; work = 0; - gc_phase = Phase_idle; + caml_gc_phase = Phase_idle; }else{ - gc_sweep_hp = chunk; + caml_gc_sweep_hp = chunk; limit = chunk + Chunk_size (chunk); } } @@ -289,95 +294,104 @@ static void sweep_slice (long work) [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) +long caml_major_collection_slice (long howmuch) { - double p; + double p, dp; 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) + FM = caml_stat_heap_size * caml_percent_free + / (100 + caml_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 + G is also the amount of memory that will be used during this cycle (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 + PH = caml_allocated_words / G + = caml_allocated_words * 3 * (100 + caml_percent_free) + / (2 * caml_stat_heap_size * caml_percent_free) + Proportion of extra-heap resources consumed since the previous slice: + PE = caml_extra_heap_resources 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) + MW = caml_stat_heap_size * 100 / (100 + caml_percent_free) Amount of sweeping work for the GC cycle: - SW = stat_heap_size + SW = caml_stat_heap_size Amount of marking work for this slice: MS = P * MW - MS = P * stat_heap_size * 100 / (100 + percent_free) + MS = P * caml_stat_heap_size * 100 / (100 + caml_percent_free) Amount of sweeping work for this slice: SS = P * SW - SS = P * stat_heap_size + SS = P * caml_stat_heap_size This slice will either mark 2*MS words or sweep 2*SS words. */ - if (gc_phase == Phase_idle) start_cycle (); + if (caml_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)); + p = (double) caml_allocated_words * 3.0 * (100 + caml_percent_free) + / Wsize_bsize (caml_stat_heap_size) / caml_percent_free / 2.0; + if (caml_dependent_size > 0){ + dp = (double) caml_dependent_allocated * (100 + caml_percent_free) + / caml_dependent_size / caml_percent_free; + }else{ + dp = 0.0; + } + if (p < dp) p = dp; + if (p < caml_extra_heap_resources) p = caml_extra_heap_resources; + + caml_gc_message (0x40, "allocated_words = %lu\n", caml_allocated_words); + caml_gc_message (0x40, "extra_heap_resources = %luu\n", + (unsigned long) (caml_extra_heap_resources * 1000000)); + caml_gc_message (0x40, "amount of work to do = %luu\n", + (unsigned long) (p * 1000000)); + + if (caml_gc_phase == Phase_mark){ + computed_work = 2 * (long) (p * Wsize_bsize (caml_stat_heap_size) * 100 + / (100 + caml_percent_free)); }else{ - computed_work = 2 * (long) (p * Wsize_bsize (stat_heap_size)); + computed_work = 2 * (long) (p * Wsize_bsize (caml_stat_heap_size)); } - gc_message (0x40, "ordered work = %ld words\n", howmuch); - gc_message (0x40, "computed work = %ld words\n", computed_work); + caml_gc_message (0x40, "ordered work = %ld words\n", howmuch); + caml_gc_message (0x40, "computed work = %ld words\n", computed_work); if (howmuch == 0) howmuch = computed_work; - if (gc_phase == Phase_mark){ + if (caml_gc_phase == Phase_mark){ mark_slice (howmuch); - gc_message (0x02, "!", 0); + caml_gc_message (0x02, "!", 0); }else{ - Assert (gc_phase == Phase_sweep); + Assert (caml_gc_phase == Phase_sweep); sweep_slice (howmuch); - gc_message (0x02, "$", 0); + caml_gc_message (0x02, "$", 0); } - if (gc_phase == Phase_idle) compact_heap_maybe (); + if (caml_gc_phase == Phase_idle) caml_compact_heap_maybe (); - stat_major_words += allocated_words; - allocated_words = 0; - extra_heap_memory = 0.0; + caml_stat_major_words += caml_allocated_words; + caml_allocated_words = 0; + caml_dependent_allocated = 0; + caml_extra_heap_resources = 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 +/* This does not call caml_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. + Besides, this function is called by caml_compact_heap_maybe. */ -void finish_major_cycle (void) +void caml_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; + if (caml_gc_phase == Phase_idle) start_cycle (); + while (caml_gc_phase == Phase_mark) mark_slice (LONG_MAX); + Assert (caml_gc_phase == Phase_sweep); + while (caml_gc_phase == Phase_sweep) sweep_slice (LONG_MAX); + Assert (caml_gc_phase == Phase_idle); + caml_stat_major_words += caml_allocated_words; + caml_allocated_words = 0; } /* Make sure the request is at least Heap_chunk_min and round it up @@ -391,68 +405,68 @@ static asize_t clip_heap_chunk_size (asize_t request) return ((request + Page_size - 1) >> Page_log) << Page_log; } -/* Make sure the request is >= major_heap_increment, then call +/* Make sure the request is >= caml_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 caml_round_heap_chunk_size (asize_t request) { asize_t result = request; - if (result < major_heap_increment){ - result = major_heap_increment; + if (result < caml_major_heap_increment){ + result = caml_major_heap_increment; } result = clip_heap_chunk_size (result); if (result < request){ - raise_out_of_memory (); + caml_raise_out_of_memory (); return 0; /* not reached */ } return result; } -void init_major_heap (asize_t heap_size) +void caml_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); + caml_stat_heap_size = clip_heap_chunk_size (heap_size); + caml_stat_top_heap_size = caml_stat_heap_size; + Assert (caml_stat_heap_size % Page_size == 0); + caml_heap_start = (char *) caml_alloc_for_heap (caml_stat_heap_size); + if (caml_heap_start == NULL) + caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n"); + Chunk_next (caml_heap_start) = NULL; + caml_heap_end = caml_heap_start + caml_stat_heap_size; + Assert ((unsigned long) caml_heap_end % Page_size == 0); - stat_heap_chunks = 1; + caml_stat_heap_chunks = 1; - page_low = Page (heap_start); - page_high = Page (heap_end); + caml_page_low = Page (caml_heap_start); + caml_page_high = Page (caml_heap_end); - page_table_size = page_high - page_low; + page_table_size = caml_page_high - caml_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"); + caml_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; + caml_page_table = page_table_block - caml_page_low; + for (i = Page (caml_heap_start); i < Page (caml_heap_end); i++){ + caml_page_table [i] = In_heap; } - fl_init_merge (); - make_free_blocks ((value *) heap_start, Wsize_bsize (stat_heap_size), 1); - gc_phase = Phase_idle; + caml_fl_init_merge (); + caml_make_free_blocks ((value *) caml_heap_start, + Wsize_bsize (caml_stat_heap_size), 1); + caml_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"); + caml_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; + caml_allocated_words = 0; + caml_extra_heap_resources = 0.0; } diff --git a/byterun/major_gc.h b/byterun/major_gc.h index 7d433b13..a0c5b2aa 100644 --- a/byterun/major_gc.h +++ b/byterun/major_gc.h @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.h,v 1.17 2002/11/15 16:15:19 doligez Exp $ */ +/* $Id: major_gc.h,v 1.20 2004/06/14 15:17:43 doligez Exp $ */ -#ifndef _major_gc_ -#define _major_gc_ +#ifndef CAML_MAJOR_GC_H +#define CAML_MAJOR_GC_H #include "freelist.h" @@ -32,10 +32,11 @@ typedef struct { #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; +extern int caml_gc_phase; +extern unsigned long caml_allocated_words; +extern double caml_extra_heap_resources; +extern unsigned long caml_dependent_size, caml_dependent_allocated; +extern unsigned long caml_fl_size_at_phase_change; #define Phase_mark 0 #define Phase_sweep 1 @@ -47,27 +48,27 @@ typedef int page_table_entry; typedef char page_table_entry; #endif -CAMLextern char *heap_start; -CAMLextern char *heap_end; +CAMLextern char *caml_heap_start; +CAMLextern char *caml_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; +CAMLextern page_table_entry *caml_page_table; +extern asize_t caml_page_low, caml_page_high; +extern char *caml_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)]) + (addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \ + && caml_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 caml_init_major_heap (asize_t); /* size in bytes */ +asize_t caml_round_heap_chunk_size (asize_t); /* size in bytes */ +void caml_darken (value, value *); +long caml_major_collection_slice (long); void major_collection (void); -void finish_major_cycle (void); +void caml_finish_major_cycle (void); -#endif /* _major_gc_ */ +#endif /* CAML_MAJOR_GC_H */ diff --git a/byterun/md5.c b/byterun/md5.c index b3d58e5f..038e3fbe 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: md5.c,v 1.15 2002/04/18 07:27:38 garrigue Exp $ */ +/* $Id: md5.c,v 1.18 2004/01/01 16:42:36 doligez Exp $ */ #include #include "alloc.h" @@ -23,18 +23,18 @@ /* MD5 message digest */ -CAMLprim value md5_string(value str, value ofs, value len) +CAMLprim value caml_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); + caml_MD5Init(&ctx); + caml_MD5Update(&ctx, &Byte_u(str, Long_val(ofs)), Long_val(len)); + res = caml_alloc_string(16); + caml_MD5Final(&Byte_u(res, 0), &ctx); return res; } -CAMLprim value md5_chan(value vchan, value len) +CAMLprim value caml_md5_chan(value vchan, value len) { struct channel * chan = Channel(vchan); struct MD5Context ctx; @@ -43,25 +43,25 @@ CAMLprim value md5_chan(value vchan, value len) char buffer[4096]; Lock(chan); - MD5Init(&ctx); + caml_MD5Init(&ctx); toread = Long_val(len); if (toread < 0){ while (1){ - read = getblock (chan, buffer, sizeof(buffer)); + read = caml_getblock (chan, buffer, sizeof(buffer)); if (read == 0) break; - MD5Update (&ctx, (unsigned char *) buffer, read); + caml_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); + read = caml_getblock(chan, buffer, + toread > sizeof(buffer) ? sizeof(buffer) : toread); + if (read == 0) caml_raise_end_of_file(); + caml_MD5Update(&ctx, (unsigned char *) buffer, read); toread -= read; } } - res = alloc_string(16); - MD5Final(&Byte_u(res, 0), &ctx); + res = caml_alloc_string(16); + caml_MD5Final(&Byte_u(res, 0), &ctx); Unlock(chan); return res; } @@ -78,8 +78,8 @@ CAMLprim value md5_chan(value vchan, value len) * 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 + * MD5Context structure, pass it to caml_MD5Init, call caml_MD5Update as + * needed on buffers full of bytes, and then call caml_MD5Final, which * will fill a supplied 16-byte array with the digest. */ @@ -102,7 +102,7 @@ static void byteReverse(unsigned char * buf, unsigned longs) * Start MD5 accumulation. Set bit count to 0 and buffer to mysterious * initialization constants. */ -CAMLexport void MD5Init(struct MD5Context *ctx) +CAMLexport void caml_MD5Init(struct MD5Context *ctx) { ctx->buf[0] = 0x67452301; ctx->buf[1] = 0xefcdab89; @@ -117,8 +117,8 @@ CAMLexport void MD5Init(struct MD5Context *ctx) * Update context to reflect the concatenation of another buffer full * of bytes. */ -CAMLexport void MD5Update(struct MD5Context *ctx, unsigned char *buf, - unsigned long len) +CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf, + unsigned long len) { uint32 t; @@ -143,7 +143,7 @@ CAMLexport void MD5Update(struct MD5Context *ctx, unsigned char *buf, } memcpy(p, buf, t); byteReverse(ctx->in, 16); - MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); buf += t; len -= t; } @@ -152,7 +152,7 @@ CAMLexport void MD5Update(struct MD5Context *ctx, unsigned char *buf, while (len >= 64) { memcpy(ctx->in, buf, 64); byteReverse(ctx->in, 16); - MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); buf += 64; len -= 64; } @@ -166,7 +166,7 @@ CAMLexport void MD5Update(struct MD5Context *ctx, unsigned char *buf, * 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) +CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx) { unsigned count; unsigned char *p; @@ -187,7 +187,7 @@ CAMLexport void MD5Final(unsigned char *digest, struct MD5Context *ctx) /* 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); + caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); /* Now fill the next block with 56 bytes */ memset(ctx->in, 0, 56); @@ -201,7 +201,7 @@ CAMLexport void MD5Final(unsigned char *digest, struct MD5Context *ctx) ((uint32 *) ctx->in)[14] = ctx->bits[0]; ((uint32 *) ctx->in)[15] = ctx->bits[1]; - MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_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 */ @@ -221,10 +221,10 @@ CAMLexport void MD5Final(unsigned char *digest, struct MD5Context *ctx) /* * The core of the MD5 algorithm, this alters an existing MD5 hash to - * reflect the addition of 16 longwords of new data. MD5Update blocks + * reflect the addition of 16 longwords of new data. caml_MD5Update blocks * the data and converts bytes into longwords for this routine. */ -CAMLexport void MD5Transform(uint32 *buf, uint32 *in) +CAMLexport void caml_MD5Transform(uint32 *buf, uint32 *in) { register uint32 a, b, c, d; diff --git a/byterun/md5.h b/byterun/md5.h index 1cb9ecf3..f0ea3e81 100644 --- a/byterun/md5.h +++ b/byterun/md5.h @@ -11,19 +11,19 @@ /* */ /***********************************************************************/ -/* $Id: md5.h,v 1.10 2002/04/18 07:27:38 garrigue Exp $ */ +/* $Id: md5.h,v 1.12 2003/12/31 14:20:37 doligez Exp $ */ /* MD5 message digest */ -#ifndef _md5 -#define _md5 +#ifndef CAML_MD5_H +#define CAML_MD5_H #include "mlvalues.h" #include "io.h" -CAMLextern value md5_string (value str, value ofs, value len); -CAMLextern value md5_chan (value vchan, value len); +CAMLextern value caml_md5_string (value str, value ofs, value len); +CAMLextern value caml_md5_chan (value vchan, value len); struct MD5Context { uint32 buf[4]; @@ -31,11 +31,11 @@ struct MD5Context { 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); +CAMLextern void caml_MD5Init (struct MD5Context *context); +CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, + unsigned long len); +CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx); +CAMLextern void caml_MD5Transform (uint32 *buf, uint32 *in); -#endif +#endif /* CAML_MD5_H */ diff --git a/byterun/memory.c b/byterun/memory.c index 0befbb98..5a63976e 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: memory.c,v 1.33 2002/12/12 18:59:11 doligez Exp $ */ +/* $Id: memory.c,v 1.40 2004/06/14 15:17:43 doligez Exp $ */ #include #include @@ -21,34 +21,35 @@ #include "gc_ctrl.h" #include "major_gc.h" #include "memory.h" +#include "major_gc.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); +extern char * caml_aligned_mmap (asize_t size, int modulo, void ** block); +extern void caml_aligned_munmap (char * addr, asize_t size); #endif /* Allocate a block of the requested size, to be passed to - [add_to_heap] later. + [caml_add_to_heap] later. [request] must be a multiple of [Page_size]. - [alloc_for_heap] returns NULL if the request cannot be satisfied. + [caml_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 *caml_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); + mem = caml_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); + mem = caml_aligned_malloc (request + sizeof (heap_chunk_head), + sizeof (heap_chunk_head), &block); #endif if (mem == NULL) return NULL; mem += sizeof (heap_chunk_head); @@ -57,29 +58,29 @@ char *alloc_for_heap (asize_t request) return mem; } -/* Use this function to free a block allocated with [alloc_for_heap] - if you don't add it with [add_to_heap]. +/* Use this function to free a block allocated with [caml_alloc_for_heap] + if you don't add it with [caml_add_to_heap]. */ -void free_for_heap (char *mem) +void caml_free_for_heap (char *mem) { #ifdef USE_MMAP_INSTEAD_OF_MALLOC - aligned_munmap (Chunk_block (mem), - Chunk_size (mem) + sizeof (heap_chunk_head)); + caml_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. + call to [caml_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. + caller. All other blocks must have the color [caml_allocation_color(mem)]. + The caller must update [caml_allocated_words] if applicable. Return value: 0 if no error; -1 in case of error. */ -int add_to_heap (char *m) +int caml_add_to_heap (char *m) { asize_t i; Assert (Chunk_size (m) % Page_size == 0); @@ -88,53 +89,59 @@ int add_to_heap (char *m) #endif /* debug */ /* Extend the page table as needed. */ - if (Page (m) < page_low){ + if (Page (m) < caml_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; + asize_t new_size = caml_page_high - new_page_low; - gc_message (0x08, "Growing page table to %lu entries\n", new_size); + caml_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); + caml_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; + for (i = new_page_low; i < caml_page_low; i++){ + new_page_table [i] = Not_in_heap; + } + for (i = caml_page_low; i < caml_page_high; i++){ + new_page_table [i] = caml_page_table [i]; + } + free (caml_page_table + caml_page_low); + caml_page_table = new_page_table; + caml_page_low = new_page_low; } - if (Page (m + Chunk_size (m)) > page_high){ + if (Page (m + Chunk_size (m)) > caml_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; + asize_t new_size = new_page_high - caml_page_low; - gc_message (0x08, "Growing page table to %lu entries\n", new_size); + caml_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); + caml_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 = block - caml_page_low; + for (i = caml_page_low; i < caml_page_high; i++){ + new_page_table [i] = caml_page_table [i]; + } + for (i = caml_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; + free (caml_page_table + caml_page_low); + caml_page_table = new_page_table; + caml_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; + caml_page_table [i] = In_heap; } /* Chain this heap chunk. */ { - char **last = &heap_start; + char **last = &caml_heap_start; char *cur = *last; while (cur != NULL && cur < m){ @@ -144,15 +151,17 @@ int add_to_heap (char *m) Chunk_next (m) = cur; *last = m; - ++ stat_heap_chunks; + ++ caml_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); + /* already done: if (m < caml_heap_start) heap_start = m; */ + if (m + Chunk_size (m) > caml_heap_end) caml_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; + caml_stat_heap_size += Chunk_size (m); + if (caml_stat_heap_size > caml_stat_top_heap_size){ + caml_stat_top_heap_size = caml_stat_heap_size; + } return 0; } @@ -167,19 +176,19 @@ 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); + malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (request)); + caml_gc_message (0x04, "Growing heap to %luk bytes\n", + (caml_stat_heap_size + malloc_request) / 1024); + mem = caml_alloc_for_heap (malloc_request); if (mem == NULL){ - gc_message (0x04, "No room for growing heap\n", 0); + caml_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); + if (caml_add_to_heap (mem) != 0){ + caml_free_for_heap (mem); return NULL; } return Bp_hp (mem); @@ -188,21 +197,22 @@ static char *expand_heap (mlsize_t request) /* Remove the heap chunk [chunk] from the heap and give the memory back to [free]. */ -void shrink_heap (char *chunk) +void caml_shrink_heap (char *chunk) { char **cp; asize_t i; - /* Never deallocate the first block, because heap_start is both the + /* Never deallocate the first block, because caml_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; + if (chunk == caml_heap_start) return; - stat_heap_size -= Chunk_size (chunk); - gc_message (0x04, "Shrinking heap to %luk bytes\n", stat_heap_size / 1024); + caml_stat_heap_size -= Chunk_size (chunk); + caml_gc_message (0x04, "Shrinking heap to %luk bytes\n", + caml_stat_heap_size / 1024); #ifdef DEBUG { @@ -213,66 +223,70 @@ void shrink_heap (char *chunk) } #endif - -- stat_heap_chunks; + -- caml_stat_heap_chunks; /* Remove [chunk] from the list of chunks. */ - cp = &heap_start; + cp = &caml_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; + caml_page_table [i] = Not_in_heap; } /* Free the [malloc] block that contains [chunk]. */ - free_for_heap (chunk); + caml_free_for_heap (chunk); } -color_t allocation_color (void *hp) +color_t caml_allocation_color (void *hp) { - if (gc_phase == Phase_mark - || (gc_phase == Phase_sweep && (addr)hp >= (addr)gc_sweep_hp)){ + if (caml_gc_phase == Phase_mark + || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){ return Caml_black; }else{ - Assert (gc_phase == Phase_idle - || (gc_phase == Phase_sweep && (addr)hp < (addr)gc_sweep_hp)); + Assert (caml_gc_phase == Phase_idle + || (caml_gc_phase == Phase_sweep + && (addr)hp < (addr)caml_gc_sweep_hp)); return Caml_white; } } -value alloc_shr (mlsize_t wosize, tag_t tag) +CAMLexport value caml_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 (wosize > Max_wosize) caml_raise_out_of_memory (); + hp = caml_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"); + if (caml_in_minor_collection) + caml_fatal_error ("Fatal error: out of memory.\n"); else - raise_out_of_memory (); + caml_raise_out_of_memory (); } - fl_add_block (new_block); - hp = fl_allocate (wosize); + caml_fl_add_block (new_block); + hp = caml_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)){ + /* Inline expansion of caml_allocation_color. */ + if (caml_gc_phase == Phase_mark + || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_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)); + Assert (caml_gc_phase == Phase_idle + || (caml_gc_phase == Phase_sweep + && (addr)hp < (addr)caml_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 (); + Assert (Hd_hp (hp) == Make_header (wosize, tag, caml_allocation_color (hp))); + caml_allocated_words += Whsize_wosize (wosize); + if (caml_allocated_words > Wsize_bsize (caml_minor_heap_size)){ + caml_urge_major_slice (); + } #ifdef DEBUG { unsigned long i; @@ -284,77 +298,101 @@ value alloc_shr (mlsize_t wosize, tag_t tag) return Val_hp (hp); } +/* Dependent memory is all memory blocks allocated out of the heap + that depend on the GC (and finalizers) for deallocation. + For the GC to take dependent memory in its automatic speed setting, + you must call [caml_alloc_dependent_memory] when you alloate some + dependent memory, and [caml_free_dependent_memory] when you + free it. In both cases, you pass as argument the size of the + block being allocated or freed. +*/ +CAMLexport void caml_alloc_dependent_memory (mlsize_t nbytes) +{ + caml_dependent_size += nbytes / sizeof (value); + caml_dependent_allocated += nbytes / sizeof (value); +} + +CAMLexport void caml_free_dependent_memory (mlsize_t nbytes) +{ + if (caml_dependent_size < nbytes / sizeof (value)){ + caml_dependent_size = 0; + }else{ + caml_dependent_size -= nbytes / sizeof (value); + } +} + /* 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]. + finalized blocks to automatically deallocate resources (other + than memory). The GC will do at least one cycle every [max] + allocated resources; [res] is the number of resources allocated + this time. + Note that only [res/max] is relevant. The units (and kind of + resource) can change between calls to [caml_adjust_gc_speed]. */ -void adjust_gc_speed (mlsize_t mem, mlsize_t max) +CAMLexport void caml_adjust_gc_speed (mlsize_t res, 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 (res > max) res = max; + caml_extra_heap_resources += (double) res / (double) max; + if (caml_extra_heap_resources > 1.0){ + caml_extra_heap_resources = 1.0; + caml_urge_major_slice (); } - if (extra_heap_memory > (double) Wsize_bsize (minor_heap_size) - / 2.0 / (double) Wsize_bsize (stat_heap_size)) { - urge_major_slice (); + if (caml_extra_heap_resources + > (double) Wsize_bsize (caml_minor_heap_size) / 2.0 + / (double) Wsize_bsize (caml_stat_heap_size)) { + caml_urge_major_slice (); } } -/* You must use [initialize] to store the initial value in a field of +/* You must use [caml_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) +/* [caml_initialize] never calls the GC, so you may call it while an block is + unfinished (i.e. just after a call to [caml_alloc_shr].) */ +void caml_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 (); + *caml_ref_table_ptr++ = fp; + if (caml_ref_table_ptr >= caml_ref_table_limit){ + caml_realloc_ref_table (); } } } -/* You must use [modify] to change a field of an existing shared block, +/* You must use [caml_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) +/* [caml_modify] never calls the GC. */ +void caml_modify (value *fp, value val) { Modify (fp, val); } -void * stat_alloc (asize_t sz) +CAMLexport void * caml_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 (); + if (result == NULL && sz != 0) caml_raise_out_of_memory (); #ifdef DEBUG memset (result, Debug_uninit_stat, sz); #endif return result; } -void stat_free (void * blk) +CAMLexport void caml_stat_free (void * blk) { free (blk); } -void * stat_resize (void * blk, asize_t sz) +CAMLexport void * caml_stat_resize (void * blk, asize_t sz) { void * result = realloc (blk, sz); - if (result == NULL) raise_out_of_memory (); + if (result == NULL) caml_raise_out_of_memory (); return result; } diff --git a/byterun/memory.h b/byterun/memory.h index a36de8aa..b03683eb 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -11,14 +11,16 @@ /* */ /***********************************************************************/ -/* $Id: memory.h,v 1.41 2002/12/12 18:59:11 doligez Exp $ */ +/* $Id: memory.h,v 1.50.2.1 2004/07/03 10:01:00 doligez Exp $ */ /* Allocation macros and functions */ -#ifndef _memory_ -#define _memory_ - +#ifndef CAML_MEMORY_H +#define CAML_MEMORY_H +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif #include "config.h" /* */ #include "gc.h" @@ -28,20 +30,22 @@ #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 */ +CAMLextern value caml_alloc_shr (mlsize_t, tag_t); +CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); +CAMLextern void caml_alloc_dependent_memory (mlsize_t); +CAMLextern void caml_free_dependent_memory (mlsize_t); +CAMLextern void caml_modify (value *, value); +CAMLextern void caml_initialize (value *, value); +CAMLextern value caml_check_urgent_gc (value); +CAMLextern void * caml_stat_alloc (asize_t); /* Size in bytes. */ +CAMLextern void caml_stat_free (void *); +CAMLextern void * caml_stat_resize (void *, asize_t); /* Size in bytes. */ +char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */ +void caml_free_for_heap (char *mem); +int caml_add_to_heap (char *mem); +color_t caml_allocation_color (void *hp); + +/* void caml_shrink_heap (char *); Only used in compact.c */ /* */ @@ -56,19 +60,19 @@ color_t allocation_color (void *hp); #define DEBUG_clear(result, wosize) #endif -#define Alloc_small(result, wosize, tag) do{ CAMLassert (wosize >= 1); \ - CAMLassert ((tag_t) tag < 256); \ +#define Alloc_small(result, wosize, tag) do{ CAMLassert ((wosize) >= 1); \ + CAMLassert ((tag_t) (tag) < 256); \ CAMLassert ((wosize) <= Max_young_wosize); \ - young_ptr -= Bhsize_wosize (wosize); \ - if (young_ptr < young_limit){ \ - young_ptr += Bhsize_wosize (wosize); \ + caml_young_ptr -= Bhsize_wosize (wosize); \ + if (caml_young_ptr < caml_young_limit){ \ + caml_young_ptr += Bhsize_wosize (wosize); \ Setup_for_gc; \ - minor_collection (); \ + caml_minor_collection (); \ Restore_after_gc; \ - young_ptr -= Bhsize_wosize (wosize); \ + caml_young_ptr -= Bhsize_wosize (wosize); \ } \ - Hd_hp (young_ptr) = Make_header ((wosize), (tag), Caml_black); \ - (result) = Val_hp (young_ptr); \ + Hd_hp (caml_young_ptr) = Make_header ((wosize), (tag), Caml_black); \ + (result) = Val_hp (caml_young_ptr); \ DEBUG_clear ((result), (wosize)); \ }while(0) @@ -87,13 +91,13 @@ color_t allocation_color (void *hp); value _old_ = *(fp); \ *(fp) = (val); \ if (Is_in_heap (fp)){ \ - if (gc_phase == Phase_mark) darken (_old_, NULL); \ + if (caml_gc_phase == Phase_mark) caml_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 (); \ + *caml_ref_table_ptr++ = (fp); \ + if (caml_ref_table_ptr >= caml_ref_table_limit){ \ + CAMLassert (caml_ref_table_ptr == caml_ref_table_limit); \ + caml_realloc_ref_table (); \ } \ } \ } \ @@ -108,7 +112,7 @@ struct caml__roots_block { value *tables [5]; }; -CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ +CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ /* The following macros are used to declare C local variables and function parameters of type [value]. @@ -128,7 +132,7 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ 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 + Your function may raise an 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]. @@ -139,7 +143,7 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ */ #define CAMLparam0() \ - struct caml__roots_block *caml__frame = local_roots + struct caml__roots_block *caml__frame = caml_local_roots #define CAMLparam1(x) \ CAMLparam0 (); \ @@ -166,11 +170,17 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ CAMLxparamN (x, (size)) +#if defined (__GNUC__) + #define CAMLunused __attribute__ ((unused)) +#else + #define CAMLunused +#endif + #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), \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 1), \ (caml__roots_##x.tables [0] = &x), \ @@ -178,9 +188,9 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #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), \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 2), \ (caml__roots_##x.tables [0] = &x), \ @@ -189,9 +199,9 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #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), \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 3), \ (caml__roots_##x.tables [0] = &x), \ @@ -201,9 +211,9 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #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), \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 4), \ (caml__roots_##x.tables [0] = &x), \ @@ -214,9 +224,9 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #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), \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 5), \ (caml__roots_##x.tables [0] = &x), \ @@ -228,9 +238,9 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #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), \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = (size)), \ (caml__roots_##x.ntables = 1), \ (caml__roots_##x.tables[0] = &(x[0])), \ @@ -262,20 +272,23 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #define CAMLreturn0 do{ \ - local_roots = caml__frame; \ + caml_local_roots = caml__frame; \ return; \ }while (0) #define CAMLreturn(result) do{ \ - local_roots = caml__frame; \ + caml_local_roots = caml__frame; \ return (result); \ }while(0) +#define CAMLnoreturn ((void) caml__frame) + + /* 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); \ + caml_modify (&Field ((block), caml__temp_offset), caml__temp_val); \ }while(0) /* @@ -302,16 +315,16 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #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.next = caml_local_roots; \ + caml_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.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ caml__roots_block.nitems = 1; \ caml__roots_block.ntables = 2; \ caml__roots_block.tables[0] = &(r0); \ @@ -319,8 +332,8 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #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.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ caml__roots_block.nitems = 1; \ caml__roots_block.ntables = 3; \ caml__roots_block.tables[0] = &(r0); \ @@ -329,8 +342,8 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #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.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ caml__roots_block.nitems = 1; \ caml__roots_block.ntables = 4; \ caml__roots_block.tables[0] = &(r0); \ @@ -340,8 +353,8 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #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.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ caml__roots_block.nitems = 1; \ caml__roots_block.ntables = 5; \ caml__roots_block.tables[0] = &(r0); \ @@ -352,26 +365,25 @@ CAMLextern struct caml__roots_block *local_roots; /* defined in roots.c */ #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.next = caml_local_roots; \ + caml_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; } +#define End_roots() caml_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 +/* [caml_register_global_root] registers a global C variable as a memory root + for the duration of the program, or until [caml_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 caml_register_global_root (value *); -CAMLextern void remove_global_root (value *); +/* [caml_remove_global_root] removes a memory root registered on a global C + variable with [caml_register_global_root]. */ +CAMLextern void caml_remove_global_root (value *); -#endif /* _memory_ */ +#endif /* CAML_MEMORY_H */ diff --git a/byterun/meta.c b/byterun/meta.c index edbc278f..477e4a03 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: meta.c,v 1.24 2002/05/07 13:17:12 xleroy Exp $ */ +/* $Id: meta.c,v 1.31 2004/04/26 14:09:01 basile Exp $ */ /* Primitives for the toplevel */ @@ -20,6 +20,7 @@ #include "fail.h" #include "fix_code.h" #include "interp.h" +#include "intext.h" #include "major_gc.h" #include "memory.h" #include "minor_gc.h" @@ -30,52 +31,64 @@ #ifndef NATIVE_CODE -CAMLprim value get_global_data(value unit) +CAMLprim value caml_get_global_data(value unit) { - return global_data; + return caml_global_data; } -CAMLprim value reify_bytecode(value prog, value len) +char * caml_section_table = NULL; +asize_t caml_section_table_size; + +CAMLprim value caml_get_section_table(value unit) +{ + if (caml_section_table == NULL) caml_raise_not_found(); + return caml_input_value_from_block(caml_section_table, + caml_section_table_size); +} + +CAMLprim value caml_reify_bytecode(value prog, value len) { value clos; #ifdef ARCH_BIG_ENDIAN - fixup_endianness((code_t) prog, (asize_t) Long_val(len)); + caml_fixup_endianness((code_t) prog, (asize_t) Long_val(len)); #endif #ifdef THREADED_CODE - thread_code((code_t) prog, (asize_t) Long_val(len)); + caml_thread_code((code_t) prog, (asize_t) Long_val(len)); #endif - clos = alloc_small (1, Closure_tag); + caml_prepare_bytecode((code_t) prog, (asize_t) Long_val(len)); + clos = caml_alloc_small (1, Closure_tag); Code_val(clos) = (code_t) prog; return clos; } -CAMLprim value realloc_global(value size) +CAMLprim value caml_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); + actual_size = Wosize_val(caml_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); + caml_gc_message (0x08, "Growing global data to %lu entries\n", + requested_size); + new_global_data = caml_alloc_shr(requested_size, 0); for (i = 0; i < actual_size; i++) - initialize(&Field(new_global_data, i), Field(global_data, i)); + caml_initialize(&Field(new_global_data, i), Field(caml_global_data, i)); for (i = actual_size; i < requested_size; i++){ Field (new_global_data, i) = Val_long (0); } - global_data = new_global_data; + caml_global_data = new_global_data; } return Val_unit; } -CAMLprim value get_current_environment(value unit) +CAMLprim value caml_get_current_environment(value unit) { - return *extern_sp; + return *caml_extern_sp; } -CAMLprim value invoke_traced_function(value codeptr, value env, value arg) +CAMLprim value caml_invoke_traced_function(value codeptr, value env, value arg) { /* Stack layout on entry: return frame into instrument_closure function @@ -103,9 +116,9 @@ CAMLprim value invoke_traced_function(value codeptr, value env, value arg) value * osp, * nsp; int i; - osp = extern_sp; - extern_sp -= 4; - nsp = extern_sp; + osp = caml_extern_sp; + caml_extern_sp -= 4; + nsp = caml_extern_sp; for (i = 0; i < 6; i++) nsp[i] = osp[i]; nsp[6] = codeptr; nsp[7] = env; @@ -118,43 +131,43 @@ CAMLprim value invoke_traced_function(value codeptr, value env, value arg) /* Dummy definitions to support compilation of ocamlc.opt */ -value get_global_data(value unit) +value caml_get_global_data(value unit) { - invalid_argument("Meta.get_global_data"); + caml_invalid_argument("Meta.get_global_data"); return Val_unit; /* not reached */ } -value realloc_global(value size) +value caml_get_section_table(value unit) { - invalid_argument("Meta.realloc_global"); + caml_invalid_argument("Meta.get_section_table"); return Val_unit; /* not reached */ } - -value available_primitives(value unit) + +value caml_realloc_global(value size) { - invalid_argument("Meta.available_primitives"); + caml_invalid_argument("Meta.realloc_global"); return Val_unit; /* not reached */ } - -value invoke_traced_function(value codeptr, value env, value arg) + +value caml_invoke_traced_function(value codeptr, value env, value arg) { - invalid_argument("Meta.invoke_traced_function"); + caml_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; +value * caml_stack_low; +value * caml_stack_high; +value * caml_stack_threshold; +value * caml_extern_sp; +value * caml_trapsp; +int caml_backtrace_active; +int caml_backtrace_pos; +code_t * caml_backtrace_buffer; +value caml_backtrace_last_exn; +int caml_callback_depth; +int volatile caml_something_to_do; +void (* volatile caml_async_action_hook)(void); +void caml_print_exception_backtrace(void) { } +struct longjmp_buffer * caml_external_raise; #endif diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index ecb09efe..d66e4065 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: minor_gc.c,v 1.36 2002/09/18 13:59:27 doligez Exp $ */ +/* $Id: minor_gc.c,v 1.42 2004/01/05 20:25:59 doligez Exp $ */ #include #include "config.h" @@ -27,15 +27,15 @@ #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; +asize_t caml_minor_heap_size; +CAMLexport char *caml_young_start = NULL, *caml_young_end = NULL; +CAMLexport char *caml_young_ptr = NULL, *caml_young_limit = NULL; static value **ref_table = NULL, **ref_table_end, **ref_table_threshold; -value **ref_table_ptr = NULL, **ref_table_limit; +CAMLexport value **caml_ref_table_ptr = NULL, **caml_ref_table_limit; static asize_t ref_table_size, ref_table_reserve; -int in_minor_collection = 0; +int caml_in_minor_collection = 0; -void set_minor_heap_size (asize_t size) +void caml_set_minor_heap_size (asize_t size) { char *new_heap; value **new_table; @@ -43,27 +43,27 @@ void set_minor_heap_size (asize_t size) 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); + if (caml_young_ptr != caml_young_end) caml_minor_collection (); + Assert (caml_young_ptr == caml_young_end); + new_heap = (char *) caml_stat_alloc (size); + if (caml_young_start != NULL){ + caml_stat_free (caml_young_start); } - young_start = new_heap; - young_end = new_heap + size; - young_limit = young_start; - young_ptr = young_end; - minor_heap_size = size; + caml_young_start = new_heap; + caml_young_end = new_heap + size; + caml_young_limit = caml_young_start; + caml_young_ptr = caml_young_end; + caml_minor_heap_size = size; - ref_table_size = minor_heap_size / sizeof (value) / 8; + ref_table_size = caml_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); + new_table = (value **) caml_stat_alloc ((ref_table_size + ref_table_reserve) + * sizeof (value *)); + if (ref_table != NULL) caml_stat_free (ref_table); ref_table = new_table; - ref_table_ptr = ref_table; + caml_ref_table_ptr = ref_table; ref_table_threshold = ref_table + ref_table_size; - ref_table_limit = ref_table_threshold; + caml_ref_table_limit = ref_table_threshold; ref_table_end = ref_table + ref_table_size + ref_table_reserve; } @@ -72,7 +72,7 @@ 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) +void caml_oldify_one (value v, value *p) { value result; header_t hd; @@ -81,7 +81,7 @@ void oldify_one (value v, value *p) tail_call: if (Is_block (v) && Is_young (v)){ - Assert (Hp_val (v) >= young_ptr); + Assert (Hp_val (v) >= caml_young_ptr); hd = Hd_val (v); if (hd == 0){ /* If already forwarded */ *p = Field (v, 0); /* then forward pointer is first field. */ @@ -91,7 +91,7 @@ void oldify_one (value v, value *p) value field0; sz = Wosize_hd (hd); - result = alloc_shr (sz, tag); + result = caml_alloc_shr (sz, tag); *p = result; field0 = Field (v, 0); Hd_val (v) = 0; /* Set forward flag */ @@ -108,14 +108,14 @@ void oldify_one (value v, value *p) } }else if (tag >= No_scan_tag){ sz = Wosize_hd (hd); - result = alloc_shr (sz, tag); + result = caml_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. */ + caml_oldify_one (v - offset, p); /* Cannot recurse deeper than 1. */ *p += offset; }else{ value f = Forward_val (v); @@ -125,11 +125,10 @@ void oldify_one (value v, value *p) 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). */ + if (ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ + /* Do not short-circuit the pointer. Copy as a normal block. */ Assert (Wosize_hd (hd) == 1); - result = alloc_shr (1, Forward_tag); + result = caml_alloc_shr (1, Forward_tag); *p = result; Hd_val (v) = 0; /* Set (GC) forward flag */ Field (v, 0) = result; /* and forward pointer. */ @@ -147,11 +146,11 @@ void oldify_one (value v, value *p) } } -/* Finish the work that was put off by oldify_one. - Note that oldify_one itself is called by oldify_mopup, so we +/* Finish the work that was put off by [caml_oldify_one]. + Note that [caml_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) +void caml_oldify_mopup (void) { value v, new_v, f; mlsize_t i; @@ -164,12 +163,12 @@ void oldify_mopup (void) f = Field (new_v, 0); if (Is_block (f) && Is_young (f)){ - oldify_one (f, &Field (new_v, 0)); + caml_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)); + caml_oldify_one (f, &Field (new_v, i)); }else{ Field (new_v, i) = f; } @@ -180,32 +179,32 @@ void oldify_mopup (void) /* Make sure the minor heap is empty by performing a minor collection if needed. */ -void empty_minor_heap (void) +void caml_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); + if (caml_young_ptr != caml_young_end){ + caml_in_minor_collection = 1; + caml_gc_message (0x02, "<", 0); + caml_oldify_local_roots(); + for (r = ref_table; r < caml_ref_table_ptr; r++){ + caml_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; + caml_oldify_mopup (); + if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start; + caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr); + caml_young_ptr = caml_young_end; + caml_young_limit = caml_young_start; + caml_ref_table_ptr = ref_table; + caml_ref_table_limit = ref_table_threshold; + caml_gc_message (0x02, ">", 0); + caml_in_minor_collection = 0; } - final_empty_young (); + caml_final_empty_young (); #ifdef DEBUG { value *p; - for (p = (value *) young_start; p < (value *) young_end; ++p){ + for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p){ *p = Debug_free_minor; } } @@ -216,51 +215,53 @@ void empty_minor_heap (void) functions, etc. Leave the minor heap empty. */ -void minor_collection (void) +CAMLexport void caml_minor_collection (void) { - long prev_alloc_words = allocated_words; + long prev_alloc_words = caml_allocated_words; - empty_minor_heap (); + caml_empty_minor_heap (); - stat_promoted_words += allocated_words - prev_alloc_words; - ++ stat_minor_collections; - major_collection_slice (0); - force_major_slice = 0; + caml_stat_promoted_words += caml_allocated_words - prev_alloc_words; + ++ caml_stat_minor_collections; + caml_major_collection_slice (0); + caml_force_major_slice = 0; - final_do_calls (); + caml_final_do_calls (); - empty_minor_heap (); + caml_empty_minor_heap (); } -value check_urgent_gc (value extra_root) +CAMLexport value caml_check_urgent_gc (value extra_root) { CAMLparam1 (extra_root); - if (force_major_slice) minor_collection(); + if (caml_force_major_slice) caml_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); +void caml_realloc_ref_table (void) +{ Assert (caml_ref_table_ptr == caml_ref_table_limit); + Assert (caml_ref_table_limit <= ref_table_end); + Assert (caml_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 (); + if (caml_ref_table_limit == ref_table_threshold){ + caml_gc_message (0x08, "ref_table threshold crossed\n", 0); + caml_ref_table_limit = ref_table_end; + caml_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); + asize_t cur_ptr = caml_ref_table_ptr - ref_table; + Assert (caml_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); + caml_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"); + if (ref_table == NULL){ + caml_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; + caml_ref_table_ptr = ref_table + cur_ptr; + caml_ref_table_limit = ref_table_end; } } diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h index 414bb1f3..380b38ef 100644 --- a/byterun/minor_gc.h +++ b/byterun/minor_gc.h @@ -11,36 +11,37 @@ /* */ /***********************************************************************/ -/* $Id: minor_gc.h,v 1.15 2002/01/20 17:39:06 doligez Exp $ */ +/* $Id: minor_gc.h,v 1.17 2003/12/31 14:20:37 doligez Exp $ */ -#ifndef _minor_gc_ -#define _minor_gc_ +#ifndef CAML_MINOR_GC_H +#define CAML_MINOR_GC_H #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; +CAMLextern char *caml_young_start, *caml_young_ptr; +CAMLextern char *caml_young_end, *caml_young_limit; +CAMLextern value **caml_ref_table_ptr, **caml_ref_table_limit; +extern asize_t caml_minor_heap_size; +extern int caml_in_minor_collection; #define Is_young(val) \ (Assert (Is_block (val)), \ - (addr)(val) < (addr)young_end && (addr)(val) > (addr)young_start) + (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_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); +extern void caml_set_minor_heap_size (asize_t); +extern void caml_empty_minor_heap (void); +CAMLextern void caml_minor_collection (void); +CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */ +extern void caml_realloc_ref_table (void); +extern void caml_oldify_one (value, value *); +extern void caml_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)); \ + caml_oldify_one (__oldify__v__, (p)); \ } \ }while(0) -#endif /* _minor_gc_ */ +#endif /* CAML_MINOR_GC_H */ diff --git a/byterun/misc.c b/byterun/misc.c index e3f1990f..b21c9088 100644 --- a/byterun/misc.c +++ b/byterun/misc.c @@ -11,15 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: misc.c,v 1.22 2002/01/20 17:39:06 doligez Exp $ */ +/* $Id: misc.c,v 1.26 2004/04/01 13:07:57 xleroy Exp $ */ #include #include "config.h" #include "misc.h" #include "memory.h" -#ifdef HAS_UI -#include "ui.h" -#endif #ifdef DEBUG @@ -32,58 +29,39 @@ int caml_failed_assert (char * expr, char * file, int line) return 1; /* not reached */ } -#endif +#endif /* DEBUG */ -unsigned long verb_gc = 0; +unsigned long caml_verb_gc = 0; -void gc_message (int level, char *msg, unsigned long arg) +void caml_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 + if (level < 0 || (caml_verb_gc & level) != 0){ fprintf (stderr, msg, arg); fflush (stderr); -#endif } } -void fatal_error (char *msg) +CAMLexport void caml_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) +CAMLexport void caml_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) +CAMLexport void caml_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 *caml_aligned_malloc (asize_t size, int modulo, void **block) { char *raw_mem; unsigned long aligned_mem; @@ -109,20 +87,20 @@ char *aligned_malloc (asize_t size, int modulo, void **block) return (char *) (aligned_mem - modulo); } -void ext_table_init(struct ext_table * tbl, int init_capa) +void caml_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); + tbl->contents = caml_stat_alloc(sizeof(void *) * init_capa); } -int ext_table_add(struct ext_table * tbl, void * data) +int caml_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); + caml_stat_resize(tbl->contents, sizeof(void *) * tbl->capacity); } res = tbl->size; tbl->contents[res] = data; @@ -130,10 +108,10 @@ int ext_table_add(struct ext_table * tbl, void * data) return res; } -void ext_table_free(struct ext_table * tbl, int free_entries) +void caml_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); + for (i = 0; i < tbl->size; i++) caml_stat_free(tbl->contents[i]); + caml_stat_free(tbl->contents); } diff --git a/byterun/misc.h b/byterun/misc.h index 6323367c..bef725d1 100644 --- a/byterun/misc.h +++ b/byterun/misc.h @@ -11,14 +11,16 @@ /* */ /***********************************************************************/ -/* $Id: misc.h,v 1.24 2003/05/12 14:21:52 xleroy Exp $ */ +/* $Id: misc.h,v 1.30 2004/05/17 17:09:59 doligez Exp $ */ /* Miscellaneous macros and variables. */ -#ifndef _misc_ -#define _misc_ - +#ifndef CAML_MISC_H +#define CAML_MISC_H +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif #include "config.h" /* Standard definitions */ @@ -39,10 +41,10 @@ typedef char * addr; /* */ #ifdef __GNUC__ -/* Works only in GCC 2.5 and later */ -#define Noreturn __attribute ((noreturn)) + /* Works only in GCC 2.5 and later */ + #define Noreturn __attribute__ ((noreturn)) #else -#define Noreturn + #define Noreturn #endif /* Export control (to mark primitives and to handle Windows DLL) */ @@ -67,15 +69,15 @@ typedef char * addr; #ifdef DEBUG #define CAMLassert(x) ((x) ? 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) -int caml_failed_assert (char *, char *, int); +CAMLextern int caml_failed_assert (char *, char *, int); #else -#define CAMLassert(x) 0 +#define CAMLassert(x) ((void) 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; +CAMLextern void caml_fatal_error (char *msg) Noreturn; +CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) Noreturn; +CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, + char *fmt2, char *arg2) Noreturn; /* Data structures */ @@ -85,18 +87,18 @@ struct ext_table { 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); +extern void caml_ext_table_init(struct ext_table * tbl, int init_capa); +extern int caml_ext_table_add(struct ext_table * tbl, void * data); +extern void caml_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); +extern unsigned long caml_verb_gc; +void caml_gc_message (int, char *, unsigned long); /* Memory routines */ -char *aligned_malloc (asize_t, int, void **); +char *caml_aligned_malloc (asize_t, int, void **); #ifdef DEBUG #ifdef ARCH_SIXTYFOUR @@ -111,14 +113,14 @@ char *aligned_malloc (asize_t, int, void **); 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 + 04 -> fields deallocated by [caml_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 + 15 -> uninitialised words of [caml_aligned_malloc] blocks + 85 -> filler bytes of [caml_aligned_malloc] special case (byte by byte): - D7 -> uninitialised words of stat_alloc blocks + D7 -> uninitialised words of [caml_stat_alloc] blocks */ #define Debug_free_minor Debug_tag (0x00) #define Debug_free_major Debug_tag (0x01) @@ -139,4 +141,4 @@ char *aligned_malloc (asize_t, int, void **); /* */ -#endif /* _misc_ */ +#endif /* CAML_MISC_H */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index f589b0b8..92efb49a 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -11,12 +11,14 @@ /* */ /***********************************************************************/ -/* $Id: mlvalues.h,v 1.40 2003/03/31 08:41:12 xleroy Exp $ */ - -#ifndef _mlvalues_ -#define _mlvalues_ +/* $Id: mlvalues.h,v 1.48.6.1 2004/07/07 01:14:43 garrigue Exp $ */ +#ifndef CAML_MLVALUES_H +#define CAML_MLVALUES_H +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif #include "config.h" #include "misc.h" @@ -162,7 +164,7 @@ 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. + See [caml_oldify_one] in minor_gc.c for more details. NOTE: Update stdlib/obj.ml whenever you change the tags. */ @@ -185,6 +187,8 @@ typedef opcode_t * code_t; #define Object_tag 248 #define Class_val(val) Field((val), 0) #define Oid_val(val) Long_val(Field((val), 1)) +CAMLextern value caml_get_public_method (value obj, value tag); +/* called as: callback(caml_get_public_method(obj, hash_variant(name)), obj) */ /* Special case of tuples of fields: closures */ #define Closure_tag 247 @@ -195,7 +199,7 @@ typedef opcode_t * code_t; #define Lazy_tag 246 /* Another special case: variants */ -CAMLextern value hash_variant(char * tag); +CAMLextern value caml_hash_variant(char * tag); /* 2- If tag >= No_scan_tag : a sequence of bytes. */ @@ -214,7 +218,7 @@ CAMLextern value hash_variant(char * tag); /* Strings. */ #define String_tag 252 #define String_val(x) ((char *) Bp_val(x)) -CAMLextern mlsize_t string_length (value); /* size in bytes */ +CAMLextern mlsize_t caml_string_length (value); /* size in bytes */ /* Floating-point numbers. */ #define Double_tag 253 @@ -223,8 +227,10 @@ CAMLextern mlsize_t string_length (value); /* size in bytes */ #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); +CAMLextern double caml_Double_val (value); +CAMLextern void caml_Store_double_val (value,double); +#define Double_val(v) caml_Double_val(v) +#define Store_double_val(v,d) caml_Store_double_val(v,d) #endif /* Arrays of floating-point numbers. */ @@ -252,13 +258,14 @@ struct custom_operations; /* defined in [custom.h] */ #ifndef ARCH_ALIGN_INT64 #define Int64_val(v) (*((int64 *) Data_custom_val(v))) #else -CAMLextern int64 Int64_val(value v); +CAMLextern int64 caml_Int64_val(value v); +#define Int64_val(v) caml_Int64_val(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)]))) +CAMLextern header_t caml_atom_table[]; +#define Atom(tag) (Val_hp (&(caml_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) @@ -269,10 +276,11 @@ CAMLextern header_t atom_table[]; #ifndef NATIVE_CODE #define Is_atom(v) ((v) >= Atom(0) && (v) <= Atom(255)) #else -CAMLextern char * static_data_start, * static_data_end; +CAMLextern char * caml_static_data_start, * caml_static_data_end; #define Is_atom(v) \ - ((((char *)(v) >= static_data_start && (char *)(v) < static_data_end) || \ - ((v) >= Atom(0) && (v) <= Atom(255)))) + ((((char *)(v) >= caml_static_data_start \ + && (char *)(v) < caml_static_data_end) \ + || ((v) >= Atom(0) && (v) <= Atom(255)))) #endif /* Booleans are integers 0 or 1 */ @@ -293,7 +301,7 @@ CAMLextern char * static_data_start, * static_data_end; /* The table of global identifiers */ -extern value global_data; +extern value caml_global_data; -#endif /* _mlvalues_ */ +#endif /* CAML_MLVALUES_H */ diff --git a/byterun/mpwtool.c b/byterun/mpwtool.c deleted file mode 100644 index f9f47dd1..00000000 --- a/byterun/mpwtool.c +++ /dev/null @@ -1,39 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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 index ac5d29c8..54d9c541 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: obj.c,v 1.20 2003/06/23 12:46:13 xleroy Exp $ */ +/* $Id: obj.c,v 1.34 2004/06/05 01:15:53 garrigue Exp $ */ /* Operations on objects */ @@ -19,6 +19,7 @@ #include "alloc.h" #include "fail.h" #include "gc.h" +#include "interp.h" #include "major_gc.h" #include "memory.h" #include "minor_gc.h" @@ -26,39 +27,60 @@ #include "mlvalues.h" #include "prims.h" -CAMLprim value static_alloc(value size) +CAMLprim value caml_static_alloc(value size) { - return (value) stat_alloc((asize_t) Long_val(size)); + return (value) caml_stat_alloc((asize_t) Long_val(size)); } -CAMLprim value static_free(value blk) +CAMLprim value caml_static_free(value blk) { - stat_free((void *) blk); + caml_stat_free((void *) blk); return Val_unit; } -CAMLprim value static_resize(value blk, value new_size) +/* signal to the interpreter machinery that a bytecode is no more + needed (before freeing it) - this might be useful for a JIT + implementation */ + +CAMLprim value caml_static_release_bytecode(value blk, value size) { - return (value) stat_resize((char *) blk, (asize_t) Long_val(new_size)); +#ifndef NATIVE_CODE + caml_release_bytecode((code_t) blk, (asize_t) Long_val(size)); +#else + caml_failwith("Meta.static_release_bytecode impossible with native code"); +#endif + return Val_unit; } -CAMLprim value obj_is_block(value arg) + +CAMLprim value caml_static_resize(value blk, value new_size) +{ + return (value) caml_stat_resize((char *) blk, (asize_t) Long_val(new_size)); +} + +CAMLprim value caml_obj_is_block(value arg) { return Val_bool(Is_block(arg)); } -CAMLprim value obj_tag(value arg) +CAMLprim value caml_obj_tag(value arg) { - return Val_int(Tag_val(arg)); + if (Is_long (arg)){ + return 1000; + }else if (Is_young (arg) || Is_in_heap (arg)){ + return Val_int(Tag_val(arg)); + }else{ + return 1001; + } } -CAMLprim value obj_set_tag (value arg, value new_tag) +CAMLprim value caml_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) +CAMLprim value caml_obj_block(value tag, value size) { value res; mlsize_t sz, i; @@ -67,14 +89,14 @@ CAMLprim value obj_block(value tag, value size) sz = Long_val(size); tg = Long_val(tag); if (sz == 0) return Atom(tg); - res = alloc(sz, tg); + res = caml_alloc(sz, tg); for (i = 0; i < sz; i++) Field(res, i) = Val_long(0); return res; } -CAMLprim value obj_dup(value arg) +CAMLprim value caml_obj_dup(value arg) { CAMLparam1 (arg); CAMLlocal1 (res); @@ -85,14 +107,14 @@ CAMLprim value obj_dup(value arg) if (sz == 0) return arg; tg = Tag_val(arg); if (tg >= No_scan_tag) { - res = alloc(sz, tg); + res = caml_alloc(sz, tg); memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value)); } else if (sz <= Max_young_wosize) { - res = alloc_small(sz, tg); + res = caml_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)); + res = caml_alloc_shr(sz, tg); + for (i = 0; i < sz; i++) caml_initialize(&Field(res, i), Field(arg, i)); } CAMLreturn (res); } @@ -106,7 +128,7 @@ CAMLprim value obj_dup(value arg) 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) +CAMLprim value caml_obj_truncate (value v, value newsize) { mlsize_t new_wosize = Long_val (newsize); header_t hd = Hd_val (v); @@ -117,14 +139,16 @@ CAMLprim value obj_truncate (value v, value newsize) 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 <= 0 || new_wosize > wosize){ + caml_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); + caml_modify(&Field(v, i), Val_unit); #ifdef DEBUG Field (v, i) = Debug_free_truncate; #endif @@ -140,21 +164,92 @@ CAMLprim value obj_truncate (value v, value newsize) } -/* [lazy_is_forward] and [lazy_follow_forward] are used in stdlib/lazy.ml. +/* The following functions 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) +/* [lazy_is_forward] is obsolete. Stays here to make bootstrapping + easier for patched versions of 3.07. To be removed before 3.08. FIXME */ +/* +CAMLxxprim value lazy_is_forward (value v) { return Val_bool (Is_block (v) && Tag_val (v) == Forward_tag); } +*/ -CAMLprim value lazy_follow_forward (value v) +CAMLprim value caml_lazy_follow_forward (value v) { - if (Is_block (v) && Tag_val (v) == Forward_tag){ + if (Is_block (v) && (Is_young (v) || Is_in_heap (v)) + && Tag_val (v) == Forward_tag){ return Forward_val (v); }else{ return v; } } + +CAMLprim value caml_lazy_make_forward (value v) +{ + CAMLparam1 (v); + CAMLlocal1 (res); + + res = caml_alloc_small (1, Forward_tag); + Modify (&Field (res, 0), v); + CAMLreturn (res); +} + +/* For camlinternalOO.ml + See also GETPUBMET in interp.c + */ + +CAMLprim value caml_get_public_method (value obj, value tag) +{ + value meths = Field (obj, 0); + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (tag < Field(meths,mi)) hi = mi-2; + else li = mi; + } + return Field (meths, li-1); +} + +/* these two functions might be useful to an hypothetical JIT */ + +#ifdef CAML_JIT +#ifdef NATIVE_CODE +#define MARK 1 +#else +#define MARK 0 +#endif +value caml_cache_public_method (value meths, value tag, value *cache) +{ + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (tag < Field(meths,mi)) hi = mi-2; + else li = mi; + } + *cache = (li-3)*sizeof(value) + MARK; + return Field (meths, li-1); +} + +value caml_cache_public_method2 (value *meths, value tag, value *cache) +{ + value ofs = *cache & meths[1]; + if (*(value*)(((char*)(meths+3)) + ofs - MARK) == tag) + return *(value*)(((char*)(meths+2)) + ofs - MARK); + { + int li = 3, hi = meths[0], mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (tag < meths[mi]) hi = mi-2; + else li = mi; + } + *cache = (li-3)*sizeof(value) + MARK; + return meths[li-1]; + } +} +#endif /*CAML_JIT*/ + +/* eof $Id: obj.c,v 1.34 2004/06/05 01:15:53 garrigue Exp $ */ diff --git a/byterun/osdeps.h b/byterun/osdeps.h index 02be9eac..beddd9b7 100644 --- a/byterun/osdeps.h +++ b/byterun/osdeps.h @@ -15,26 +15,25 @@ /* Operating system - specific stuff */ -#ifndef _osdeps_ - -#define _osdeps_ +#ifndef CAML_OSDEPS_H +#define CAML_OSDEPS_H #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); +extern char * caml_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); + [caml_stat_alloc]. */ +extern char * caml_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); +CAMLextern char * caml_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); +extern char * caml_search_dll_in_path(struct ext_table * path, char * name); /* Open a shared library and return a handle on it. Return [NULL] on error. */ @@ -57,8 +56,8 @@ 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); +extern int caml_executable_name(char * name, int name_len); #endif -#endif +#endif /* CAML_OSDEPS_H */ diff --git a/byterun/parsing.c b/byterun/parsing.c index e0a26f87..37e00db2 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: parsing.c,v 1.17 2002/11/01 17:06:42 doligez Exp $ */ +/* $Id: parsing.c,v 1.20 2004/05/17 17:09:59 doligez Exp $ */ /* The PDA automaton for parsers generated by camlyacc */ @@ -70,7 +70,7 @@ struct parser_env { /* Mirrors parser_env in ../stdlib/parsing.ml */ #define Short(tbl,n) (((short *)(tbl))[n]) #endif -int parser_trace = 0; +int caml_parser_trace = 0; /* Input codes */ /* Mirrors parser_input in ../stdlib/parsing.ml */ @@ -115,7 +115,6 @@ static char * token_name(char * names, int number) static void print_token(struct parser_tables *tables, int state, value tok) { - mlsize_t i; value v; if (Is_long(tok)) { @@ -139,8 +138,8 @@ static void print_token(struct parser_tables *tables, int state, value tok) /* The pushdown automata */ -CAMLprim value parse_engine(struct parser_tables *tables, - struct parser_env *env, value cmd, value arg) +CAMLprim value caml_parse_engine(struct parser_tables *tables, + struct parser_env *env, value cmd, value arg) { int state; mlsize_t sp, asp; @@ -166,12 +165,12 @@ CAMLprim value parse_engine(struct parser_tables *tables, RESTORE; if (Is_block(arg)) { env->curr_char = Field(tables->transl_block, Tag_val(arg)); - modify(&env->lval, Field(arg, 0)); + caml_modify(&env->lval, Field(arg, 0)); } else { env->curr_char = Field(tables->transl_const, Int_val(arg)); - modify(&env->lval, Val_long(0)); + caml_modify(&env->lval, Val_long(0)); } - if (parser_trace) print_token(tables, state, arg); + if (caml_parser_trace) print_token(tables, state, arg); testshift: n1 = Short(tables->sindex, state); @@ -200,13 +199,17 @@ CAMLprim value parse_engine(struct parser_tables *tables, n2 = n1 + ERRCODE; if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && Short(tables->check, n2) == ERRCODE) { - if (parser_trace) + if (caml_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 (caml_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"); + if (caml_parser_trace){ + fprintf(stderr, "No more states to discard\n"); + } return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */ } sp--; @@ -215,7 +218,7 @@ CAMLprim value parse_engine(struct parser_tables *tables, } 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"); + if (caml_parser_trace) fprintf(stderr, "Discarding last token read\n"); env->curr_char = Val_int(-1); goto loop; } @@ -224,7 +227,7 @@ CAMLprim value parse_engine(struct parser_tables *tables, env->curr_char = Val_int(-1); if (errflag > 0) errflag--; shift_recover: - if (parser_trace) + if (caml_parser_trace) fprintf(stderr, "State %d: shift to state %d\n", state, Short(tables->table, n2)); state = Short(tables->table, n2); @@ -237,13 +240,13 @@ CAMLprim value parse_engine(struct parser_tables *tables, RESTORE; push: Field(env->s_stack, sp) = Val_int(state); - modify(&Field(env->v_stack, sp), env->lval); + caml_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) + if (caml_parser_trace) fprintf(stderr, "State %d: reduce by rule %d\n", state, n); m = Short(tables->len, n); env->asp = Val_int(sp); @@ -273,7 +276,7 @@ CAMLprim value parse_engine(struct parser_tables *tables, case SEMANTIC_ACTION_COMPUTED: RESTORE; Field(env->s_stack, sp) = Val_int(state); - modify(&Field(env->v_stack, sp), arg); + caml_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) { diff --git a/byterun/prims.h b/byterun/prims.h index b7180f71..f4e76f39 100644 --- a/byterun/prims.h +++ b/byterun/prims.h @@ -11,23 +11,26 @@ /* */ /***********************************************************************/ -/* $Id: prims.h,v 1.7 2003/05/26 12:41:54 xleroy Exp $ */ +/* $Id: prims.h,v 1.10 2004/02/22 15:07:51 xleroy Exp $ */ /* Interface with C primitives. */ -#ifndef _prims_ -#define _prims_ +#ifndef CAML_PRIMS_H +#define CAML_PRIMS_H typedef value (*c_primitive)(); -extern c_primitive builtin_cprim[]; -extern char * names_of_builtin_cprim[]; +extern c_primitive caml_builtin_cprim[]; +extern char * caml_names_of_builtin_cprim[]; -extern struct ext_table prim_table; +extern struct ext_table caml_prim_table; #ifdef DEBUG -extern struct ext_table prim_name_table; +extern struct ext_table caml_prim_name_table; #endif -#define Primitive(n) ((c_primitive)(prim_table.contents[n])) +#define Primitive(n) ((c_primitive)(caml_prim_table.contents[n])) -#endif /* _prims_ */ +extern char * caml_section_table; +extern asize_t caml_section_table_size; + +#endif /* CAML_PRIMS_H */ diff --git a/byterun/printexc.c b/byterun/printexc.c index 97b7efd3..90811534 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: printexc.c,v 1.13 2001/12/07 13:39:34 xleroy Exp $ */ +/* $Id: printexc.c,v 1.16 2004/01/08 22:28:48 doligez Exp $ */ /* Print an uncaught exception and abort */ @@ -24,9 +24,6 @@ #include "fail.h" #include "misc.h" #include "mlvalues.h" -#ifdef HAS_UI -#include "ui.h" -#endif #include "printexc.h" struct stringbuf { @@ -48,7 +45,7 @@ static void add_string(struct stringbuf *buf, char *s) buf->ptr += len; } -CAMLexport char * format_caml_exception(value exn) +CAMLexport char * caml_format_exception(value exn) { mlsize_t start, i; value bucket, v; @@ -96,7 +93,7 @@ CAMLexport char * format_caml_exception(value exn) } -void fatal_uncaught_exception(value exn) +void caml_fatal_uncaught_exception(value exn) { char * msg; value * at_exit; @@ -104,35 +101,29 @@ void fatal_uncaught_exception(value exn) int saved_backtrace_active, saved_backtrace_pos; #endif /* Build a string representation of the exception */ - msg = format_caml_exception(exn); + msg = caml_format_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; + saved_backtrace_active = caml_backtrace_active; + saved_backtrace_pos = caml_backtrace_pos; + caml_backtrace_active = 0; #endif at_exit = caml_named_value("Pervasives.do_at_exit"); - if (at_exit != NULL) callback_exn(*at_exit, Val_unit); + if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit); #ifndef NATIVE_CODE - backtrace_active = saved_backtrace_active; - backtrace_pos = saved_backtrace_pos; + caml_backtrace_active = saved_backtrace_active; + caml_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(); + if (caml_backtrace_active && !caml_debugger_in_use){ + caml_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 index 0bef3809..c050b27b 100644 --- a/byterun/printexc.h +++ b/byterun/printexc.h @@ -11,17 +11,17 @@ /* */ /***********************************************************************/ -/* $Id: printexc.h,v 1.3 2001/12/07 13:39:34 xleroy Exp $ */ +/* $Id: printexc.h,v 1.5 2004/01/01 16:42:37 doligez Exp $ */ -#ifndef _printexc_ -#define _printexc_ +#ifndef CAML_PRINTEXC_H +#define CAML_PRINTEXC_H #include "misc.h" #include "mlvalues.h" -CAMLextern char * format_caml_exception (value); -void fatal_uncaught_exception (value) Noreturn; +CAMLextern char * caml_format_exception (value); +void caml_fatal_uncaught_exception (value) Noreturn; -#endif /* _printexc_ */ +#endif /* CAML_PRINTEXC_H */ diff --git a/byterun/reverse.h b/byterun/reverse.h index 97cefd15..26c0e01a 100644 --- a/byterun/reverse.h +++ b/byterun/reverse.h @@ -11,12 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: reverse.h,v 1.11 2002/04/18 07:27:38 garrigue Exp $ */ +/* $Id: reverse.h,v 1.12 2003/12/15 18:10:48 doligez Exp $ */ /* Swap byte-order in 16, 32, and 64-bit integers or floats */ -#ifndef _reverse_ -#define _reverse_ +#ifndef CAML_REVERSE_H +#define CAML_REVERSE_H #define Reverse_16(dst,src) { \ char * _p, * _q; \ @@ -85,4 +85,4 @@ _p[Perm_index(perm_dst, 7)] = _h; \ } -#endif /* _reverse_ */ +#endif /* CAML_REVERSE_H */ diff --git a/byterun/roots.c b/byterun/roots.c index 8f386d8d..ba848d93 100644 --- a/byterun/roots.c +++ b/byterun/roots.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: roots.c,v 1.24 2002/01/18 15:13:25 doligez Exp $ */ +/* $Id: roots.c,v 1.28 2004/01/05 20:25:59 doligez Exp $ */ /* To walk the memory roots for garbage collection */ @@ -25,14 +25,15 @@ #include "roots.h" #include "stacks.h" -CAMLexport struct caml__roots_block *local_roots = NULL; +CAMLexport struct caml__roots_block *caml_local_roots = NULL; -void (*scan_roots_hook) (scanning_action f) = NULL; +CAMLexport void (*caml_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 +/* FIXME should rename to [caml_oldify_young_roots] and synchronise with + asmrun/roots.c */ +/* Call [caml_oldify_one] on (at least) all the roots that point to the minor heap. */ -void oldify_local_roots (void) +void caml_oldify_local_roots (void) { register value * sp; struct global_root * gr; @@ -40,57 +41,58 @@ void oldify_local_roots (void) long i, j; /* The stack */ - for (sp = extern_sp; sp < stack_high; sp++) { - oldify_one (*sp, sp); + for (sp = caml_extern_sp; sp < caml_stack_high; sp++) { + caml_oldify_one (*sp, sp); } /* Local C roots */ /* FIXME do the old-frame trick ? */ - for (lr = local_roots; lr != NULL; lr = lr->next) { + for (lr = caml_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); + caml_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); + caml_oldify_one(*(gr->root), gr->root); } /* Finalised values */ - final_do_young_roots (&oldify_one); + caml_final_do_young_roots (&caml_oldify_one); /* Hook */ - if (scan_roots_hook != NULL) (*scan_roots_hook)(&oldify_one); + if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one); } -/* Call [darken] on all roots */ +/* Call [caml_darken] on all roots */ -void darken_all_roots (void) +void caml_darken_all_roots (void) { - do_roots (darken); + caml_do_roots (caml_darken); } -void do_roots (scanning_action f) +void caml_do_roots (scanning_action f) { struct global_root * gr; /* Global variables */ - f(global_data, &global_data); + f(caml_global_data, &caml_global_data); /* The stack and the local C roots */ - do_local_roots(f, extern_sp, stack_high, local_roots); + caml_do_local_roots(f, caml_extern_sp, caml_stack_high, caml_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); + caml_final_do_strong_roots (f); /* Hook */ - if (scan_roots_hook != NULL) (*scan_roots_hook)(f); + if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f); } -void do_local_roots (scanning_action f, value *stack_low, value *stack_high, - struct caml__roots_block *local_roots) +CAMLexport void caml_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; diff --git a/byterun/roots.h b/byterun/roots.h index 642ffeb2..e2055fa4 100644 --- a/byterun/roots.h +++ b/byterun/roots.h @@ -11,28 +11,28 @@ /* */ /***********************************************************************/ -/* $Id: roots.h,v 1.16 2001/12/07 13:39:36 xleroy Exp $ */ +/* $Id: roots.h,v 1.18 2004/01/01 16:42:37 doligez Exp $ */ -#ifndef _roots_ -#define _roots_ +#ifndef CAML_ROOTS_H +#define CAML_ROOTS_H #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); +void caml_oldify_local_roots (void); +void caml_darken_all_roots (void); +void caml_do_roots (scanning_action); #ifndef NATIVE_CODE -CAMLextern void do_local_roots (scanning_action, value *, value *, - struct caml__roots_block *); +CAMLextern void caml_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); +CAMLextern void caml_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); +CAMLextern void (*caml_scan_roots_hook) (scanning_action); -#endif /* _roots_ */ +#endif /* CAML_ROOTS_H */ diff --git a/byterun/rotatecursor.c b/byterun/rotatecursor.c deleted file mode 100644 index 9c0e4e87..00000000 --- a/byterun/rotatecursor.c +++ /dev/null @@ -1,120 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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 deleted file mode 100644 index 6710c02c..00000000 --- a/byterun/rotatecursor.h +++ /dev/null @@ -1,124 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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 index 98b35d2e..58410144 100644 --- a/byterun/signals.c +++ b/byterun/signals.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: signals.c,v 1.39 2002/04/18 07:27:38 garrigue Exp $ */ +/* $Id: signals.c,v 1.46 2004/01/08 22:28:48 doligez Exp $ */ #include #include "alloc.h" @@ -25,49 +25,43 @@ #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) +extern sighandler caml_win32_signal(int sig, sighandler action); +#define signal(sig,act) caml_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; +CAMLexport int volatile caml_async_signal_mode = 0; +CAMLexport int volatile caml_pending_signal = 0; +CAMLexport int volatile caml_something_to_do = 0; +int volatile caml_force_major_slice = 0; +value caml_signal_handlers = 0; +CAMLexport void (*caml_enter_blocking_section_hook)(void) = NULL; +CAMLexport void (*caml_leave_blocking_section_hook)(void) = NULL; +CAMLexport void (* volatile caml_async_action_hook)(void) = NULL; -void process_event(void) +void caml_process_event(void) { int signal_number; void (*async_action)(void); - if (force_major_slice) minor_collection (); /* FIXME should be check_urgent_gc */ + if (caml_force_major_slice) caml_minor_collection (); + /* FIXME should be [caml_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); + signal_number = caml_pending_signal; + caml_pending_signal = 0; + if (signal_number) caml_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; + async_action = caml_async_action_hook; + caml_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) +void caml_execute_signal(int signal_number, int in_signal_handler) { value res; #ifdef POSIX_SIGNALS @@ -78,8 +72,8 @@ void execute_signal(int signal_number, int in_signal_handler) 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))); + res = caml_callback_exn(Field(caml_signal_handlers, signal_number), + Val_int(rev_convert_signal_number(signal_number))); #ifdef POSIX_SIGNALS if (! in_signal_handler) { /* Restore the original signal mask */ @@ -90,66 +84,70 @@ void execute_signal(int signal_number, int in_signal_handler) sigprocmask(SIG_SETMASK, &sigs, NULL); } #endif - if (Is_exception_result(res)) mlraise(Extract_exception(res)); + if (Is_exception_result(res)) caml_raise(Extract_exception(res)); } -void handle_signal(int signal_number) +static 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 (); + if (caml_async_signal_mode){ + caml_leave_blocking_section (); + caml_execute_signal(signal_number, 1); + caml_enter_blocking_section (); }else{ - pending_signal = signal_number; - something_to_do = 1; + caml_pending_signal = signal_number; + caml_something_to_do = 1; } } -void urge_major_slice (void) +void caml_urge_major_slice (void) { - force_major_slice = 1; - something_to_do = 1; + caml_force_major_slice = 1; + caml_something_to_do = 1; } -CAMLexport void enter_blocking_section(void) +CAMLexport void caml_enter_blocking_section(void) { int temp; while (1){ - Assert (!async_signal_mode); + Assert (!caml_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; + temp = caml_pending_signal; caml_pending_signal = 0; + if (temp) caml_execute_signal(temp, 0); + caml_async_signal_mode = 1; + if (!caml_pending_signal) break; + caml_async_signal_mode = 0; + } + if (caml_enter_blocking_section_hook != NULL){ + caml_enter_blocking_section_hook(); } - if (enter_blocking_section_hook != NULL) enter_blocking_section_hook(); } -CAMLexport void leave_blocking_section(void) +CAMLexport void caml_leave_blocking_section(void) { #ifdef _WIN32 int signal_number; #endif - if (leave_blocking_section_hook != NULL) leave_blocking_section_hook(); + if (caml_leave_blocking_section_hook != NULL){ + caml_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 + [caml_pending_signal] and let the system call run to completion. + Hence, test [caml_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); + signal_number = caml_pending_signal; + caml_pending_signal = 0; + if (signal_number) caml_execute_signal(signal_number, 1); #endif - Assert(async_signal_mode); - async_signal_mode = 0; + Assert(caml_async_signal_mode); + caml_async_signal_mode = 0; } #ifndef SIGABRT @@ -222,7 +220,7 @@ static int posix_signals[] = { SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGVTALRM, SIGPROF }; -CAMLexport int convert_signal_number(int signo) +CAMLexport int caml_convert_signal_number(int signo) { if (signo < 0 && signo >= -(sizeof(posix_signals) / sizeof(int))) return posix_signals[-signo-1]; @@ -242,7 +240,7 @@ static int rev_convert_signal_number(int signo) #define NSIG 64 #endif -CAMLprim value install_signal_handler(value signal_number, value action) +CAMLprim value caml_install_signal_handler(value signal_number, value action) { CAMLparam2 (signal_number, action); int sig; @@ -252,9 +250,9 @@ CAMLprim value install_signal_handler(value signal_number, value action) #endif CAMLlocal1 (res); - sig = convert_signal_number(Int_val(signal_number)); + sig = caml_convert_signal_number(Int_val(signal_number)); if (sig < 0 || sig >= NSIG) - invalid_argument("Sys.signal: unavailable signal"); + caml_invalid_argument("Sys.signal: unavailable signal"); switch(action) { case Val_int(0): /* Signal_default */ act = SIG_DFL; @@ -270,26 +268,26 @@ CAMLprim value install_signal_handler(value signal_number, value action) sigact.sa_handler = act; sigemptyset(&sigact.sa_mask); sigact.sa_flags = 0; - if (sigaction(sig, &sigact, &oldsigact) == -1) sys_error(NO_ARG); + if (sigaction(sig, &sigact, &oldsigact) == -1) caml_sys_error(NO_ARG); oldact = oldsigact.sa_handler; #else oldact = signal(sig, act); - if (oldact == SIG_ERR) sys_error(NO_ARG); + if (oldact == SIG_ERR) caml_sys_error(NO_ARG); #endif if (oldact == handle_signal) { - res = alloc_small (1, 0); /* Signal_handle */ - Field(res, 0) = Field(signal_handlers, sig); + res = caml_alloc_small (1, 0); /* Signal_handle */ + Field(res, 0) = Field(caml_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); + if (caml_signal_handlers == 0) { + caml_signal_handlers = caml_alloc(NSIG, 0); + caml_register_global_root(&caml_signal_handlers); } - modify(&Field(signal_handlers, sig), Field(action, 0)); + caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0)); } CAMLreturn (res); } diff --git a/byterun/signals.h b/byterun/signals.h index 49cfa8e2..ccf951b8 100644 --- a/byterun/signals.h +++ b/byterun/signals.h @@ -11,35 +11,37 @@ /* */ /***********************************************************************/ -/* $Id: signals.h,v 1.18 2003/06/23 12:52:06 xleroy Exp $ */ +/* $Id: signals.h,v 1.21 2004/01/01 16:42:37 doligez Exp $ */ -#ifndef _signals_ -#define _signals_ +#ifndef CAML_SIGNALS_H +#define CAML_SIGNALS_H +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif #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; +extern value caml_signal_handlers; +CAMLextern int volatile caml_pending_signal; +CAMLextern int volatile caml_something_to_do; +extern int volatile caml_force_major_slice; +CAMLextern int volatile caml_async_signal_mode; /* */ -CAMLextern void enter_blocking_section (void); -CAMLextern void leave_blocking_section (void); +CAMLextern void caml_enter_blocking_section (void); +CAMLextern void caml_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); +void caml_urge_major_slice (void); +CAMLextern int caml_convert_signal_number (int); +void caml_execute_signal(int signal_number, int in_signal_handler); +void caml_process_event(void); + +CAMLextern void (*caml_enter_blocking_section_hook)(void); +CAMLextern void (*caml_leave_blocking_section_hook)(void); +CAMLextern void (* volatile caml_async_action_hook)(void); /* */ -#endif /* _signals_ */ - +#endif /* CAML_SIGNALS_H */ diff --git a/byterun/stacks.c b/byterun/stacks.c index 131a58a6..e9441ef5 100644 --- a/byterun/stacks.c +++ b/byterun/stacks.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: stacks.c,v 1.18 2001/12/07 13:39:36 xleroy Exp $ */ +/* $Id: stacks.c,v 1.21 2004/01/01 16:42:37 doligez Exp $ */ /* To initialize and resize the stacks */ @@ -22,81 +22,82 @@ #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; +CAMLexport value * caml_stack_low; +CAMLexport value * caml_stack_high; +CAMLexport value * caml_stack_threshold; +CAMLexport value * caml_extern_sp; +CAMLexport value * caml_trapsp; +CAMLexport value * caml_trap_barrier; +value caml_global_data; -unsigned long max_stack_size; /* also used in gc_ctrl.c */ +unsigned long caml_max_stack_size; /* also used in gc_ctrl.c */ -void init_stack (long unsigned int initial_max_size) +void caml_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)); + caml_stack_low = (value *) caml_stat_alloc(Stack_size); + caml_stack_high = caml_stack_low + Stack_size / sizeof (value); + caml_stack_threshold = caml_stack_low + Stack_threshold / sizeof (value); + caml_extern_sp = caml_stack_high; + caml_trapsp = caml_stack_high; + caml_trap_barrier = caml_stack_high + 1; + caml_max_stack_size = initial_max_size; + caml_gc_message (0x08, "Initial stack limit: %luk bytes\n", + caml_max_stack_size / 1024 * sizeof (value)); } -void realloc_stack(asize_t required_space) +void caml_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; + Assert(caml_extern_sp >= caml_stack_low); + size = caml_stack_high - caml_stack_low; do { - if (size >= max_stack_size) raise_stack_overflow(); + if (size >= caml_max_stack_size) caml_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)); + } while (size < caml_stack_high - caml_extern_sp + required_space); + caml_gc_message (0x08, "Growing stack to %luk bytes\n", + (unsigned long) size * sizeof(value) / 1024); + new_low = (value *) caml_stat_alloc(size * sizeof(value)); new_high = new_low + size; #define shift(ptr) \ - ((char *) new_high - ((char *) stack_high - (char *) (ptr))) + ((char *) new_high - ((char *) caml_stack_high - (char *) (ptr))) - new_sp = (value *) shift(extern_sp); + new_sp = (value *) shift(caml_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)) + (char *) caml_extern_sp, + (caml_stack_high - caml_extern_sp) * sizeof(value)); + caml_stat_free(caml_stack_low); + caml_trapsp = (value *) shift(caml_trapsp); + caml_trap_barrier = (value *) shift(caml_trap_barrier); + for (p = caml_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; + caml_stack_low = new_low; + caml_stack_high = new_high; + caml_stack_threshold = caml_stack_low + Stack_threshold / sizeof (value); + caml_extern_sp = new_sp; #undef shift } -CAMLprim value ensure_stack_capacity(value required_space) +CAMLprim value caml_ensure_stack_capacity(value required_space) { asize_t req = Long_val(required_space); - if (extern_sp - req < stack_low) realloc_stack(req); + if (caml_extern_sp - req < caml_stack_low) caml_realloc_stack(req); return Val_unit; } -void change_max_stack_size (long unsigned int new_max_size) +void caml_change_max_stack_size (long unsigned int new_max_size) { - asize_t size = stack_high - extern_sp + Stack_threshold / sizeof (value); + asize_t size = caml_stack_high - caml_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); + if (new_max_size != caml_max_stack_size){ + caml_gc_message (0x08, "Changing stack limit to %luk bytes\n", + new_max_size * sizeof (value) / 1024); } - max_stack_size = new_max_size; + caml_max_stack_size = new_max_size; } diff --git a/byterun/stacks.h b/byterun/stacks.h index 7a53bbba..bf1f6c96 100644 --- a/byterun/stacks.h +++ b/byterun/stacks.h @@ -11,33 +11,31 @@ /* */ /***********************************************************************/ -/* $Id: stacks.h,v 1.10 2001/12/07 13:39:36 xleroy Exp $ */ +/* $Id: stacks.h,v 1.13 2004/01/01 16:42:37 doligez Exp $ */ /* structure of the stacks */ -#ifndef _stacks_ -#define _stacks_ +#ifndef CAML_STACKS_H +#define CAML_STACKS_H #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; +CAMLextern value * caml_stack_low; +CAMLextern value * caml_stack_high; +CAMLextern value * caml_stack_threshold; +CAMLextern value * caml_extern_sp; +CAMLextern value * caml_trapsp; +CAMLextern value * caml_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); +void caml_init_stack (unsigned long init_max_size); +void caml_realloc_stack (asize_t required_size); +void caml_change_max_stack_size (unsigned long new_max_size); -#endif /* _stacks_ */ - +#endif /* CAML_STACKS_H */ diff --git a/byterun/startup.c b/byterun/startup.c index 19435aa0..f32a2e68 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: startup.c,v 1.56 2003/06/01 15:58:05 xleroy Exp $ */ +/* $Id: startup.c,v 1.64.4.1 2004/07/03 10:01:00 doligez Exp $ */ /* Start-up code */ @@ -61,16 +61,16 @@ #define SEEK_END 2 #endif -extern int parser_trace; +extern int caml_parser_trace; -CAMLexport header_t atom_table[256]; +CAMLexport header_t caml_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); + for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); } /* Read the trailer of a bytecode file */ @@ -94,35 +94,35 @@ static int read_trailer(int fd, struct exec_trailer *trail) return BAD_BYTECODE; } -int attempt_open(char **name, struct exec_trailer *trail, - int do_open_script) +int caml_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); + truename = caml_search_exe_in_path(*name); *name = truename; - gc_message(0x100, "Opening bytecode executable %s\n", - (unsigned long) truename); + caml_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); + caml_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); + caml_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); + caml_gc_message(0x100, "Not a bytecode executable\n", 0); return err; } return fd; @@ -130,15 +130,15 @@ int attempt_open(char **name, struct exec_trailer *trail, /* Read the section descriptors */ -void read_section_descriptors(int fd, struct exec_trailer *trail) +void caml_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); + trail->section = caml_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"); + caml_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)); @@ -148,7 +148,7 @@ void read_section_descriptors(int fd, struct exec_trailer *trail) 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) +int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name) { long ofs; int i; @@ -167,11 +167,11 @@ int32 seek_optional_section(int fd, struct exec_trailer *trail, char *name) /* 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 caml_seek_section(int fd, struct exec_trailer *trail, char *name) { - int32 len = seek_optional_section(fd, trail, name); + int32 len = caml_seek_optional_section(fd, trail, name); if (len == -1) - fatal_error_arg("Fatal_error: section `%s' is missing\n", name); + caml_fatal_error_arg("Fatal_error: section `%s' is missing\n", name); return len; } @@ -183,11 +183,11 @@ static char * read_section(int fd, struct exec_trailer *trail, char *name) int32 len; char * data; - len = seek_optional_section(fd, trail, name); + len = caml_seek_optional_section(fd, trail, name); if (len == -1) return NULL; - data = stat_alloc(len + 1); + data = caml_stat_alloc(len + 1); if (read(fd, data, len) != len) - fatal_error_arg("Fatal error: error reading section %s\n", name); + caml_fatal_error_arg("Fatal error: error reading section %s\n", name); data[len] = 0; return data; } @@ -236,34 +236,34 @@ static int parse_command_line(char **argv) switch(argv[i][1]) { #ifdef DEBUG case 't': - trace_flag = 1; + caml_trace_flag++; break; #endif case 'v': - verb_gc = 0x001+0x004+0x008+0x010+0x020; + caml_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]); + for (j = 0; caml_names_of_builtin_cprim[j] != NULL; j++) + printf("%s\n", caml_names_of_builtin_cprim[j]); exit(0); break; case 'b': - init_backtrace(); + caml_init_backtrace(); break; case 'I': if (argv[i + 1] != NULL) { - ext_table_add(&shared_libs_path, argv[i + 1]); + caml_ext_table_add(&caml_shared_libs_path, argv[i + 1]); i++; } break; default: - fatal_error_arg("Unknown option %s.\n", argv[i]); + caml_fatal_error_arg("Unknown option %s.\n", argv[i]); } } return i; } -/* Parse the CAMLRUNPARAM variable */ +/* Parse the OCAMLRUNPARAM 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). @@ -296,15 +296,15 @@ static void parse_camlrunparam(void) 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; + case 'v': scanmult (opt, &caml_verb_gc); break; + case 'b': caml_init_backtrace(); break; + case 'p': caml_parser_trace = 1; break; } } } } -extern void init_ieee_floats (void); +extern void caml_init_ieee_floats (void); #ifdef _WIN32 extern void caml_signal_thread(void * lpParam); @@ -326,131 +326,137 @@ CAMLexport void caml_main(char **argv) /* 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; + caml_init_ieee_floats(); + caml_init_custom_operations(); + caml_ext_table_init(&caml_shared_libs_path, 8); + caml_external_raise = NULL; /* Determine options and position of bytecode file */ #ifdef DEBUG - verb_gc = 63; + caml_verb_gc = 0xBF; #endif parse_camlrunparam(); pos = 0; exe_name = argv[0]; #ifdef __linux__ - if (executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) + if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) exe_name = proc_self_exe; #endif - fd = attempt_open(&exe_name, &trail, 0); + fd = caml_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"); + caml_fatal_error("No bytecode file specified.\n"); exe_name = argv[pos]; - fd = attempt_open(&exe_name, &trail, 1); + fd = caml_attempt_open(&exe_name, &trail, 1); switch(fd) { case FILE_NOT_FOUND: - fatal_error_arg("Fatal error: cannot find file %s\n", argv[pos]); + caml_fatal_error_arg("Fatal error: cannot find file %s\n", argv[pos]); break; case BAD_BYTECODE: - fatal_error_arg( + caml_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); + caml_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); + caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, + percent_free_init, max_percent_free_init); + caml_init_stack (max_stack_init); init_atoms(); /* Initialize the interpreter */ - interprete(NULL, 0); + caml_interprete(NULL, 0); /* Initialize the debugger, if needed */ - debugger_init(); + caml_debugger_init(); /* Load the code */ - code_size = seek_section(fd, &trail, "CODE"); - load_code(fd, code_size); + caml_code_size = caml_seek_section(fd, &trail, "CODE"); + caml_load_code(fd, caml_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); + if (req_prims == NULL) caml_fatal_error("Fatal error: no PRIM section\n"); + caml_build_primitive_table(shared_lib_path, shared_libs, req_prims); + caml_stat_free(shared_lib_path); + caml_stat_free(shared_libs); + caml_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); + caml_seek_section(fd, &trail, "DATA"); + chan = caml_open_descriptor_in(fd); + caml_global_data = caml_input_val(chan); + caml_close_channel(chan); /* this also closes fd */ + caml_stat_free(trail.section); /* Ensure that the globals are in the major heap. */ - oldify_one (global_data, &global_data); - oldify_mopup (); + caml_oldify_one (caml_global_data, &caml_global_data); + caml_oldify_mopup (); /* Initialize system libraries */ - init_exceptions(); - sys_init(exe_name, argv + pos); + caml_init_exceptions(); + caml_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); + caml_debugger(PROGRAM_START); + res = caml_interprete(caml_start_code, caml_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); + caml_exn_bucket = Extract_exception(res); + if (caml_debugger_in_use) { + caml_extern_sp = &caml_exn_bucket; /* The debugger needs the + exception value.*/ + caml_debugger(UNCAUGHT_EXC); } - fatal_uncaught_exception(exn_bucket); + caml_fatal_uncaught_exception(caml_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) +CAMLexport void caml_startup_code( + code_t code, asize_t code_size, + char *data, asize_t data_size, + char *section_table, asize_t section_table_size, + char **argv) { value res; - init_ieee_floats(); - init_custom_operations(); + caml_init_ieee_floats(); + caml_init_custom_operations(); #ifdef DEBUG - verb_gc = 63; + caml_verb_gc = 63; #endif parse_camlrunparam(); - external_raise = NULL; + caml_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); + caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, + percent_free_init, max_percent_free_init); + caml_init_stack (max_stack_init); init_atoms(); /* Initialize the interpreter */ - interprete(NULL, 0); + caml_interprete(NULL, 0); /* Load the code */ - start_code = code; + caml_start_code = code; #ifdef THREADED_CODE - thread_code(start_code, code_size); + caml_thread_code(caml_start_code, code_size); #endif /* Use the builtin table of primitives */ - prim_table.size = prim_table.capacity = -1; - prim_table.contents = (void **) builtin_cprim; + caml_build_primitive_table_builtin(); /* Load the globals */ - global_data = input_val_from_string((value)data, 0); + caml_global_data = caml_input_value_from_block(data, data_size); /* Ensure that the globals are in the major heap. */ - oldify_one (global_data, &global_data); - oldify_mopup (); + caml_oldify_one (caml_global_data, &caml_global_data); + caml_oldify_mopup (); + /* Record the sections (for caml_get_section_table in meta.c) */ + caml_section_table = section_table; + caml_section_table_size = section_table_size; /* Run the code */ - init_exceptions(); - sys_init("", argv); - res = interprete(start_code, code_size); + caml_init_exceptions(); + caml_sys_init("", argv); + res = caml_interprete(caml_start_code, code_size); if (Is_exception_result(res)) - fatal_uncaught_exception(Extract_exception(res)); + caml_fatal_uncaught_exception(Extract_exception(res)); } diff --git a/byterun/startup.h b/byterun/startup.h index 93d55f84..b103faa6 100644 --- a/byterun/startup.h +++ b/byterun/startup.h @@ -1,21 +1,40 @@ -#ifndef _startup_ -#define _startup_ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ -#include "misc.h" +/* $Id: startup.h,v 1.5 2004/02/22 15:07:51 xleroy Exp $ */ + +#ifndef CAML_STARTUP_H +#define CAML_STARTUP_H + +#include "mlvalues.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); + +CAMLextern void caml_startup_code( + code_t code, asize_t code_size, + char *data, asize_t data_size, + char *section_table, asize_t section_table_size, + 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); +extern int caml_attempt_open(char **name, struct exec_trailer *trail, + int do_open_script); +extern void caml_read_section_descriptors(int fd, struct exec_trailer *trail); +extern int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, + char *name); +extern int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name); -#endif +#endif /* CAML_STARTUP_H */ diff --git a/byterun/str.c b/byterun/str.c index 7e3af3dd..b2e28927 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: str.c,v 1.20 2003/05/06 13:52:08 xleroy Exp $ */ +/* $Id: str.c,v 1.26 2004/05/17 17:09:59 doligez Exp $ */ /* Operations on strings */ @@ -25,7 +25,7 @@ #include #endif -CAMLexport mlsize_t string_length(value s) +CAMLexport mlsize_t caml_string_length(value s) { mlsize_t temp; temp = Bosize_val(s) - 1; @@ -33,7 +33,7 @@ CAMLexport mlsize_t string_length(value s) return temp - Byte (s, temp); } -CAMLprim value ml_string_length(value s) +CAMLprim value caml_ml_string_length(value s) { mlsize_t temp; temp = Bosize_val(s) - 1; @@ -41,29 +41,31 @@ CAMLprim value ml_string_length(value s) return Val_long(temp - Byte (s, temp)); } -CAMLprim value create_string(value len) +CAMLprim value caml_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); + if (size > Bsize_wsize (Max_wosize) - 1){ + caml_invalid_argument("String.create"); + } + return caml_alloc_string(size); } -CAMLprim value string_get(value str, value index) +CAMLprim value caml_string_get(value str, value index) { long idx = Long_val(index); - if (idx < 0 || idx >= string_length(str)) invalid_argument("String.get"); + if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error(); return Val_int(Byte_u(str, idx)); } -CAMLprim value string_set(value str, value index, value newval) +CAMLprim value caml_string_set(value str, value index, value newval) { long idx = Long_val(index); - if (idx < 0 || idx >= string_length(str)) invalid_argument("String.set"); + if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error(); Byte_u(str, idx) = Int_val(newval); return Val_unit; } -CAMLprim value string_equal(value s1, value s2) +CAMLprim value caml_string_equal(value s1, value s2) { mlsize_t sz1 = Wosize_val(s1); mlsize_t sz2 = Wosize_val(s2); @@ -74,18 +76,18 @@ CAMLprim value string_equal(value s1, value s2) return Val_true; } -CAMLprim value string_notequal(value s1, value s2) +CAMLprim value caml_string_notequal(value s1, value s2) { - return Val_not(string_equal(s1, s2)); + return Val_not(caml_string_equal(s1, s2)); } -CAMLprim value string_compare(value s1, value s2) +CAMLprim value caml_string_compare(value s1, value s2) { - mlsize_t len1, len2, len; + mlsize_t len1, len2; int res; - len1 = string_length(s1); - len2 = string_length(s2); + len1 = caml_string_length(s1); + len2 = caml_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); @@ -94,39 +96,40 @@ CAMLprim value string_compare(value s1, value s2) return Val_int(0); } -CAMLprim value string_lessthan(value s1, value s2) +CAMLprim value caml_string_lessthan(value s1, value s2) { - return string_compare(s1, s2) < Val_int(0) ? Val_true : Val_false; + return caml_string_compare(s1, s2) < Val_int(0) ? Val_true : Val_false; } -CAMLprim value string_lessequal(value s1, value s2) +CAMLprim value caml_string_lessequal(value s1, value s2) { - return string_compare(s1, s2) <= Val_int(0) ? Val_true : Val_false; + return caml_string_compare(s1, s2) <= Val_int(0) ? Val_true : Val_false; } -CAMLprim value string_greaterthan(value s1, value s2) +CAMLprim value caml_string_greaterthan(value s1, value s2) { - return string_compare(s1, s2) > Val_int(0) ? Val_true : Val_false; + return caml_string_compare(s1, s2) > Val_int(0) ? Val_true : Val_false; } -CAMLprim value string_greaterequal(value s1, value s2) +CAMLprim value caml_string_greaterequal(value s1, value s2) { - return string_compare(s1, s2) >= Val_int(0) ? Val_true : Val_false; + return caml_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) +CAMLprim value caml_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) +CAMLprim value caml_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) +CAMLprim value caml_is_printable(value chr) { int c; @@ -141,7 +144,7 @@ CAMLprim value is_printable(value chr) return Val_bool(isprint(c)); } -CAMLprim value bitvect_test(value bv, value n) +CAMLprim value caml_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 index b450600c..feeaeb64 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: sys.c,v 1.63 2003/03/24 15:24:51 xleroy Exp $ */ +/* $Id: sys.c,v 1.76 2004/05/18 08:50:22 xleroy Exp $ */ /* Basic system calls */ @@ -22,16 +22,11 @@ #include #include #include -#if !macintosh #include #include -#endif -#if !macintosh && !_WIN32 +#if !_WIN32 #include #endif -#if macintosh -#include "macintosh.h" -#endif #include "config.h" #ifdef HAS_UNISTD #include @@ -51,40 +46,16 @@ #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) +static 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 @@ -92,40 +63,37 @@ char * error_message(void) #define EWOULDBLOCK (-1) #endif -CAMLexport void sys_error(value arg) +CAMLexport void caml_sys_error(value arg) { CAMLparam1 (arg); char * err; CAMLlocal1 (str); if (errno == EAGAIN || errno == EWOULDBLOCK) { - raise_sys_blocked_io(); + caml_raise_sys_blocked_io(); } else { err = error_message(); if (arg == NO_ARG) { - str = copy_string(err); + str = caml_copy_string(err); } else { int err_len = strlen(err); - int arg_len = string_length(arg); - str = alloc_string(arg_len + 2 + err_len); + int arg_len = caml_string_length(arg); + str = caml_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); + caml_raise_sys_error(str); } + CAMLnoreturn; } -CAMLprim value sys_exit(value retcode) +CAMLprim value caml_sys_exit(value retcode) { #ifndef NATIVE_CODE - debugger(PROGRAM_EXIT); + caml_debugger(PROGRAM_EXIT); #endif -#ifdef HAS_UI - ui_exit(Int_val(retcode)); -#else exit(Int_val(retcode)); -#endif return Val_unit; } @@ -148,107 +116,95 @@ static int sys_open_flags[] = { O_BINARY, O_TEXT, O_NONBLOCK }; -CAMLprim value sys_open(value path, value flags, value perm) +CAMLprim value caml_sys_open(value path, value flags, value perm) { CAMLparam3(path, flags, perm); int fd; char * p; - p = stat_alloc(string_length(path) + 1); + p = caml_stat_alloc(caml_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); + caml_enter_blocking_section(); + fd = open(p, caml_convert_flag_list(flags, sys_open_flags), Int_val(perm)); + caml_leave_blocking_section(); + caml_stat_free(p); + if (fd == -1) caml_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) +CAMLprim value caml_sys_close(value fd) { close(Int_val(fd)); return Val_unit; } -CAMLprim value sys_file_exists(value name) +CAMLprim value caml_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) +CAMLprim value caml_sys_remove(value name) { int ret; ret = unlink(String_val(name)); - if (ret != 0) sys_error(name); + if (ret != 0) caml_sys_error(name); return Val_unit; } -CAMLprim value sys_rename(value oldname, value newname) +CAMLprim value caml_sys_rename(value oldname, value newname) { if (rename(String_val(oldname), String_val(newname)) != 0) - sys_error(oldname); + caml_sys_error(NO_ARG); return Val_unit; } -CAMLprim value sys_chdir(value dirname) +CAMLprim value caml_sys_chdir(value dirname) { - if (chdir(String_val(dirname)) != 0) sys_error(dirname); + if (chdir(String_val(dirname)) != 0) caml_sys_error(dirname); return Val_unit; } -CAMLprim value sys_getcwd(value unit) +CAMLprim value caml_sys_getcwd(value unit) { char buff[4096]; #ifdef HAS_GETCWD - if (getcwd(buff, sizeof(buff)) == 0) sys_error(NO_ARG); + if (getcwd(buff, sizeof(buff)) == 0) caml_sys_error(NO_ARG); #else - if (getwd(buff) == 0) sys_error(NO_ARG); + if (getwd(buff) == 0) caml_sys_error(NO_ARG); #endif /* HAS_GETCWD */ - return copy_string(buff); + return caml_copy_string(buff); } -CAMLprim value sys_getenv(value var) +CAMLprim value caml_sys_getenv(value var) { char * res; res = getenv(String_val(var)); - if (res == 0) raise_not_found(); - return copy_string(res); + if (res == 0) caml_raise_not_found(); + return caml_copy_string(res); } char * caml_exe_name; static char ** caml_main_argv; -CAMLprim value sys_get_argv(value unit) +CAMLprim value caml_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); + exe_name = caml_copy_string(caml_exe_name); + argv = caml_copy_string_array((char const **) caml_main_argv); + res = caml_alloc_small(2, 0); Field(res, 0) = exe_name; Field(res, 1) = argv; CAMLreturn(res); } -void sys_init(char * exe_name, char **argv) +void caml_sys_init(char * exe_name, char **argv) { caml_exe_name = exe_name; caml_main_argv = argv; @@ -265,21 +221,21 @@ void sys_init(char * exe_name, char **argv) #endif #endif -CAMLprim value sys_system_command(value command) +CAMLprim value caml_sys_system_command(value command) { CAMLparam1 (command); int status, retcode; char *buf; unsigned long len; - len = string_length (command); - buf = stat_alloc (len + 1); + len = caml_string_length (command); + buf = caml_stat_alloc (len + 1); memmove (buf, String_val (command), len + 1); - enter_blocking_section (); + caml_enter_blocking_section (); status = system(buf); - leave_blocking_section (); - stat_free(buf); - if (status == -1) sys_error(command); + caml_leave_blocking_section (); + caml_stat_free(buf); + if (status == -1) caml_sys_error(command); if (WIFEXITED(status)) retcode = WEXITSTATUS(status); else @@ -287,7 +243,7 @@ CAMLprim value sys_system_command(value command) CAMLreturn (Val_int(retcode)); } -CAMLprim value sys_time(value unit) +CAMLprim value caml_sys_time(value unit) { #ifdef HAS_TIMES #ifndef CLK_TCK @@ -299,14 +255,14 @@ CAMLprim value sys_time(value unit) #endif struct tms t; times(&t); - return copy_double((double)(t.tms_utime + t.tms_stime) / CLK_TCK); + return caml_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); + return caml_copy_double((double)clock() / CLOCKS_PER_SEC); #endif } -CAMLprim value sys_random_seed (value unit) +CAMLprim value caml_sys_random_seed (value unit) { long seed; #ifdef HAS_GETTIMEOFDAY @@ -322,28 +278,28 @@ CAMLprim value sys_random_seed (value unit) return Val_long(seed); } -CAMLprim value sys_get_config(value unit) +CAMLprim value caml_sys_get_config(value unit) { CAMLparam0 (); /* unit is unused */ CAMLlocal2 (result, ostype); - ostype = copy_string(OCAML_OS_TYPE); - result = alloc_small (2, 0); + ostype = caml_copy_string(OCAML_OS_TYPE); + result = caml_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) +CAMLprim value caml_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); + caml_ext_table_init(&tbl, 50); + if (caml_read_directory(String_val(path), &tbl) == -1) caml_sys_error(path); + caml_ext_table_add(&tbl, NULL); + result = caml_copy_string_array((char const **) tbl.contents); + caml_ext_table_free(&tbl, 1); CAMLreturn(result); } diff --git a/byterun/sys.h b/byterun/sys.h index 3943df5b..86702369 100644 --- a/byterun/sys.h +++ b/byterun/sys.h @@ -11,19 +11,19 @@ /* */ /***********************************************************************/ -/* $Id: sys.h,v 1.11 2002/02/11 13:51:40 xleroy Exp $ */ +/* $Id: sys.h,v 1.15 2003/12/16 18:09:43 doligez Exp $ */ -#ifndef _sys_ -#define _sys_ +#ifndef CAML_SYS_H +#define CAML_SYS_H #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); +CAMLextern void caml_sys_error (value); +extern void caml_sys_init (char * exe_name, char ** argv); +CAMLextern value caml_sys_exit (value); extern char * caml_exe_name; -#endif /* _sys_ */ +#endif /* CAML_SYS_H */ diff --git a/byterun/terminfo.c b/byterun/terminfo.c index 2f2c78f6..1525de3c 100644 --- a/byterun/terminfo.c +++ b/byterun/terminfo.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: terminfo.c,v 1.21 2002/08/13 17:16:32 doligez Exp $ */ +/* $Id: terminfo.c,v 1.23 2004/01/01 16:42:38 doligez Exp $ */ /* Read and output terminal commands */ @@ -41,7 +41,7 @@ static char *down = NULL; static char *standout = NULL; static char *standend = NULL; -CAMLprim value terminfo_setup (value vchan) +CAMLprim value caml_terminfo_setup (value vchan) { value result; static char buffer[1024]; @@ -67,7 +67,7 @@ CAMLprim value terminfo_setup (value vchan) || standout == NULL || standend == NULL){ return Bad_term; } - result = alloc_small (1, Good_term_tag); + result = caml_alloc_small (1, Good_term_tag); Field (result, 0) = Val_int (num_lines); return result; } @@ -78,7 +78,7 @@ static int terminfo_putc (int c) return c; } -CAMLprim value terminfo_backup (value lines) +CAMLprim value caml_terminfo_backup (value lines) { int i; @@ -88,13 +88,13 @@ CAMLprim value terminfo_backup (value lines) return Val_unit; } -CAMLprim value terminfo_standout (value start) +CAMLprim value caml_terminfo_standout (value start) { tputs (Bool_val (start) ? standout : standend, 1, terminfo_putc); return Val_unit; } -CAMLprim value terminfo_resume (value lines) +CAMLprim value caml_terminfo_resume (value lines) { int i; @@ -106,26 +106,26 @@ CAMLprim value terminfo_resume (value lines) #else /* defined (HAS_TERMCAP) && !defined (NATIVE_CODE) */ -CAMLexport value terminfo_setup (value vchan) +CAMLexport value caml_terminfo_setup (value vchan) { return Bad_term; } -CAMLexport value terminfo_backup (value lines) +CAMLexport value caml_terminfo_backup (value lines) { - invalid_argument("Terminfo.backup"); + caml_invalid_argument("Terminfo.backup"); return Val_unit; } -CAMLexport value terminfo_standout (value start) +CAMLexport value caml_terminfo_standout (value start) { - invalid_argument("Terminfo.standout"); + caml_invalid_argument("Terminfo.standout"); return Val_unit; } -CAMLexport value terminfo_resume (value lines) +CAMLexport value caml_terminfo_resume (value lines) { - invalid_argument("Terminfo.resume"); + caml_invalid_argument("Terminfo.resume"); return Val_unit; } diff --git a/byterun/ui.h b/byterun/ui.h index 7f773a78..8df391dc 100644 --- a/byterun/ui.h +++ b/byterun/ui.h @@ -11,13 +11,18 @@ /* */ /***********************************************************************/ -/* $Id: ui.h,v 1.4 2001/12/07 13:39:38 xleroy Exp $ */ +/* $Id: ui.h,v 1.5 2003/12/15 18:10:49 doligez Exp $ */ /* Function declarations for non-Unix user interfaces */ +#ifndef CAML_UI_H +#define CAML_UI_H + #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); + +#endif /* CAML_UI_H */ diff --git a/byterun/unix.c b/byterun/unix.c index 1e47b720..2f3e2ecc 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id$ */ +/* $Id: unix.c,v 1.21 2004/01/03 20:55:41 doligez Exp $ */ /* Unix-specific stuff */ @@ -45,18 +45,18 @@ #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) #endif -char * decompose_path(struct ext_table * tbl, char * path) +char * caml_decompose_path(struct ext_table * tbl, char * path) { char * p, * q; int n; if (path == NULL) return NULL; - p = stat_alloc(strlen(path) + 1); + p = caml_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); + caml_ext_table_add(tbl, q); q = q + n; if (*q == 0) break; *q = 0; @@ -65,7 +65,7 @@ char * decompose_path(struct ext_table * tbl, char * path) return p; } -char * search_in_path(struct ext_table * path, char * name) +char * caml_search_in_path(struct ext_table * path, char * name) { char * p, * fullname; int i; @@ -75,16 +75,16 @@ char * search_in_path(struct ext_table * path, char * name) if (*p == '/') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 2); + fullname = caml_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); + caml_stat_free(fullname); } not_found: - fullname = stat_alloc(strlen(name) + 1); + fullname = caml_stat_alloc(strlen(name) + 1); strcpy(fullname, name); return fullname; } @@ -113,18 +113,18 @@ static char * cygwin_search_exe_in_path(struct ext_table * path, char * name) if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 6); + fullname = caml_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); + caml_stat_free(fullname); } not_found: - fullname = stat_alloc(strlen(name) + 5); + fullname = caml_stat_alloc(strlen(name) + 5); strcpy(fullname, name); if (cygwin_file_exists(fullname)) return fullname; strcat(fullname, ".exe"); @@ -135,32 +135,32 @@ static char * cygwin_search_exe_in_path(struct ext_table * path, char * name) #endif -char * search_exe_in_path(char * name) +char * caml_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")); + caml_ext_table_init(&path, 8); + tofree = caml_decompose_path(&path, getenv("PATH")); #ifndef __CYGWIN32__ - res = search_in_path(&path, name); + res = caml_search_in_path(&path, name); #else res = cygwin_search_exe_in_path(&path, name); #endif - stat_free(tofree); - ext_table_free(&path, 0); + caml_stat_free(tofree); + caml_ext_table_free(&path, 0); return res; } -char * search_dll_in_path(struct ext_table * path, char * name) +char * caml_search_dll_in_path(struct ext_table * path, char * name) { - char * dllname = stat_alloc(strlen(name) + 4); + char * dllname = caml_stat_alloc(strlen(name) + 4); char * res; strcpy(dllname, name); strcat(dllname, ".so"); - res = search_in_path(path, dllname); - stat_free(dllname); + res = caml_search_in_path(path, dllname); + caml_stat_free(dllname); return res; } @@ -292,7 +292,7 @@ char * caml_dlerror(void) #include -char *aligned_mmap (asize_t size, int modulo, void **block) +char *caml_aligned_mmap (asize_t size, int modulo, void **block) { char *raw_mem; unsigned long aligned_mem; @@ -319,7 +319,7 @@ char *aligned_mmap (asize_t size, int modulo, void **block) return (char *) (aligned_mem - modulo); } -void aligned_munmap (char * addr, asize_t size) +void caml_aligned_munmap (char * addr, asize_t size) { int retcode = munmap (addr, size + Page_size); Assert(retcode == 0); @@ -347,9 +347,9 @@ int caml_read_directory(char * dirname, struct ext_table * contents) 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); + p = caml_stat_alloc(strlen(e->d_name) + 1); strcpy(p, e->d_name); - ext_table_add(contents, p); + caml_ext_table_add(contents, p); } closedir(d); return 0; @@ -359,7 +359,7 @@ int caml_read_directory(char * dirname, struct ext_table * contents) #ifdef __linux__ -int executable_name(char * name, int name_len) +int caml_executable_name(char * name, int name_len) { int retcode; struct stat st; diff --git a/byterun/weak.c b/byterun/weak.c index 1c2d7682..4d77e292 100644 --- a/byterun/weak.c +++ b/byterun/weak.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: weak.c,v 1.20 2002/09/17 14:12:48 doligez Exp $ */ +/* $Id: weak.c,v 1.24 2004/01/01 16:42:38 doligez Exp $ */ /* Operations on weak arrays */ @@ -22,36 +22,43 @@ #include "memory.h" #include "mlvalues.h" -value weak_list_head = 0; +value caml_weak_list_head = 0; -CAMLprim value weak_create (value len) +static value weak_dummy = 0; +value caml_weak_none = (value) &weak_dummy; + +CAMLprim value caml_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; + if (size <= 0 || size > Max_wosize) caml_invalid_argument ("Weak.create"); + res = caml_alloc_shr (size, Abstract_tag); + for (i = 1; i < size; i++) Field (res, i) = caml_weak_none; + Field (res, 0) = caml_weak_list_head; + caml_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) +CAMLprim value caml_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 (offset < 1 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.set"); + } + Field (ar, offset) = caml_weak_none; 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); + }else{ + Field (ar, offset) = v; } } return Val_unit; @@ -60,19 +67,23 @@ CAMLprim value weak_set (value ar, value n, value el) #define Setup_for_gc #define Restore_after_gc -CAMLprim value weak_get (value ar, value n) +CAMLprim value caml_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){ + if (offset < 1 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.get"); + } + if (Field (ar, offset) == caml_weak_none){ res = None_val; }else{ elt = Field (ar, offset); - if (gc_phase == Phase_mark) darken (elt, NULL); - res = alloc_small (1, Some_tag); + if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (elt)){ + caml_darken (elt, NULL); + } + res = caml_alloc_small (1, Some_tag); Field (res, 0) = elt; } CAMLreturn (res); @@ -81,21 +92,24 @@ CAMLprim value weak_get (value ar, value n) #undef Setup_for_gc #undef Restore_after_gc -CAMLprim value weak_get_copy (value ar, value n) +CAMLprim value caml_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"); + if (offset < 1 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.get"); + } v = Field (ar, offset); - if (v == 0) CAMLreturn (None_val); + if (v == caml_weak_none) 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. */ + elt = caml_alloc (Wosize_val (v), Tag_val (v)); + /* The GC may erase or move v during this call to caml_alloc. */ v = Field (ar, offset); - if (v == 0) CAMLreturn (None_val); + if (v == caml_weak_none) CAMLreturn (None_val); if (Tag_val (v) < No_scan_tag){ mlsize_t i; for (i = 0; i < Wosize_val (v); i++){ @@ -107,16 +121,18 @@ CAMLprim value weak_get_copy (value ar, value n) }else{ elt = v; } - res = alloc_small (1, Some_tag); + res = caml_alloc_small (1, Some_tag); Field (res, 0) = elt; CAMLreturn (res); } -CAMLprim value weak_check (value ar, value n) +CAMLprim value caml_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); + if (offset < 1 || offset >= Wosize_val (ar)){ + caml_invalid_argument ("Weak.get"); + } + return Val_bool (Field (ar, offset) != caml_weak_none); } diff --git a/byterun/weak.h b/byterun/weak.h index cf324c5c..9b37a982 100644 --- a/byterun/weak.h +++ b/byterun/weak.h @@ -11,10 +11,16 @@ /* */ /***********************************************************************/ -/* $Id: weak.h,v 1.4 2001/12/07 13:39:38 xleroy Exp $ */ +/* $Id: weak.h,v 1.7 2004/01/01 16:42:38 doligez Exp $ */ /* Operations on weak arrays */ +#ifndef CAML_WEAK_H +#define CAML_WEAK_H + #include "mlvalues.h" -extern value weak_list_head; +extern value caml_weak_list_head; +extern value caml_weak_none; + +#endif /* CAML_WEAK_H */ diff --git a/byterun/win32.c b/byterun/win32.c index e50307fe..b3977beb 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -11,16 +11,14 @@ /* */ /***********************************************************************/ -/* $Id: win32.c,v 1.18 2003/05/12 14:21:20 xleroy Exp $ */ +/* $Id: win32.c,v 1.23 2004/01/08 22:28:48 doligez Exp $ */ /* Win32-specific stuff */ #include #include #include -#ifndef HAS_UI #include -#endif #include #include #include @@ -37,18 +35,18 @@ #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) #endif -char * decompose_path(struct ext_table * tbl, char * path) +char * caml_decompose_path(struct ext_table * tbl, char * path) { char * p, * q; int n; if (path == NULL) return NULL; - p = stat_alloc(strlen(path) + 1); + p = caml_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); + caml_ext_table_add(tbl, q); q = q + n; if (*q == 0) break; *q = 0; @@ -57,7 +55,7 @@ char * decompose_path(struct ext_table * tbl, char * path) return p; } -char * search_in_path(struct ext_table * path, char * name) +char * caml_search_in_path(struct ext_table * path, char * name) { char * p, * fullname; int i; @@ -67,26 +65,26 @@ char * search_in_path(struct ext_table * path, char * name) if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 2); + fullname = caml_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); + caml_gc_message(0x100, "Searching %s\n", (unsigned long) fullname); if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; - stat_free(fullname); + caml_stat_free(fullname); } not_found: - gc_message(0x100, "%s not found in search path\n", (unsigned long) name); - fullname = stat_alloc(strlen(name) + 1); + caml_gc_message(0x100, "%s not found in search path\n", (unsigned long) name); + fullname = caml_stat_alloc(strlen(name) + 1); strcpy(fullname, name); return fullname; } -CAMLexport char * search_exe_in_path(char * name) +CAMLexport char * caml_search_exe_in_path(char * name) { #define MAX_PATH_LENGTH 512 - char * fullname = stat_alloc(512); + char * fullname = caml_stat_alloc(512); char * filepart; if (! SearchPath(NULL, /* use system search path */ @@ -99,14 +97,14 @@ CAMLexport char * search_exe_in_path(char * name) return fullname; } -char * search_dll_in_path(struct ext_table * path, char * name) +char * caml_search_dll_in_path(struct ext_table * path, char * name) { - char * dllname = stat_alloc(strlen(name) + 5); + char * dllname = caml_stat_alloc(strlen(name) + 5); char * res; strcpy(dllname, name); strcat(dllname, ".dll"); - res = search_in_path(path, dllname); - stat_free(dllname); + res = caml_search_in_path(path, dllname); + caml_stat_free(dllname); return res; } @@ -167,15 +165,15 @@ static BOOL WINAPI ctrl_handler(DWORD event) 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; + saved_mode = caml_async_signal_mode; + caml_async_signal_mode = 0; action(SIGINT); - async_signal_mode = saved_mode; + caml_async_signal_mode = saved_mode; /* We have handled the event */ return TRUE; } -sighandler win32_signal(int sig, sighandler action) +sighandler caml_win32_signal(int sig, sighandler action) { sighandler oldaction; @@ -191,8 +189,6 @@ sighandler win32_signal(int sig, sighandler action) /* Expansion of @responsefile and *? file patterns in the command line */ -#ifndef HAS_UI - static int argc; static char ** argv; static int argvsize; @@ -317,7 +313,7 @@ static void expand_diversion(char * filename) } } -CAMLexport void expand_command_line(int * argcp, char *** argvp) +CAMLexport void caml_expand_command_line(int * argcp, char *** argvp) { int i; argc = 0; @@ -330,8 +326,6 @@ CAMLexport void expand_command_line(int * argcp, char *** argvp) *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. */ @@ -343,17 +337,17 @@ int caml_read_directory(char * dirname, struct ext_table * contents) struct _finddata_t fileinfo; char * p; - template = stat_alloc(strlen(dirname) + 5); + template = caml_stat_alloc(strlen(dirname) + 5); strcpy(template, dirname); strcat(template, "\\*.*"); h = _findfirst(template, &fileinfo); - stat_free(template); + caml_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); + p = caml_stat_alloc(strlen(fileinfo.name) + 1); strcpy(p, fileinfo.name); - ext_table_add(contents, p); + caml_ext_table_add(contents, p); } } while (_findnext(h, &fileinfo) == 0); _findclose(h); @@ -376,11 +370,11 @@ void caml_signal_thread(void * lpParam) 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)); + if (!ret || numread != 1) caml_sys_exit(Val_int(2)); switch (iobuf[0]) { case 'C': - pending_signal = SIGINT; - something_to_do = 1; + caml_pending_signal = SIGINT; + caml_something_to_do = 1; break; case 'T': raise(SIGTERM); @@ -389,4 +383,4 @@ void caml_signal_thread(void * lpParam) } } -#endif +#endif /* NATIVE_CODE */ diff --git a/camlp4/CHANGES b/camlp4/CHANGES index ca9d82f9..17bafad3 100644 --- a/camlp4/CHANGES +++ b/camlp4/CHANGES @@ -1,3 +1,23 @@ +- [05 Jul 04] creation of the `unmaintained' directory: + pa_format, pa_lefteval, pa_ocamllex, pa_olabl, pa_scheme and pa_sml + go there, each in its own subdir. Currently, they compile fine. +- [05 Jul 04] pa_ifdef, subsumed by pa_macro since 3.07, prints a warning + when loaded, encouraging use of pa_macro. +- [01 July 04] profiled versions of Camlp4 libs are *NOT* installed + by default (not even built). To build and install them, uncomment + the line PROFILING=prof in camlp4/config/Makefile.tpl, and then + make opt.opt && make install +- [22-23 June 04] `make install' now installs also pa_[or].cmx, pa_[or]p.cmx, + pa_[or]_fast.cmx, and odyl.cmx +- [12 may 04] Added to the camlp4 tools the -version option that prints + the version number, in the same way as the other ocaml tools. +- [12 may 04] Locations are now handled as in OCaml. The main benefit + is that line numbers are now correct in error messages. However, this + slightly changes the interface of a few Camlp4 modules (see ICHANGES). + ** Warning: Some contribs of the camlp4 distribution are broken because + of this change. In particular the scheme/lisp syntaxes. +- [20 nov 03] Illegal escape sequences in strings now issue a warning. + Camlp4 Version 3.07 ___________________ diff --git a/camlp4/ICHANGES b/camlp4/ICHANGES index bbb9eb14..809a65a6 100644 --- a/camlp4/ICHANGES +++ b/camlp4/ICHANGES @@ -1,6 +1,16 @@ Internal, very small, undocumented, or invisible changes ******************************************************** +- [april-may 04] the following interface files changed in order to + implement OCaml style locations: + camlp4/camlp4/{ast2pt.mli,pcaml.mli,reloc.mli,grammar.mli} + camlp4/lib/{stdpp.mli,token.mli} + The main changes are occurrences of "int" changed into + "Lexing.position" and "int * int" changed into + "Lexing.position * Lexing.position" (or an equivalent type). +- [20 nov 03], token.mli: eval_string takes a location as a extra + argument (needed to issue a warning). + Camlp4s Version 3.06+19 ----------------------- diff --git a/camlp4/Makefile b/camlp4/Makefile index f0bbf29c..25ef6748 100644 --- a/camlp4/Makefile +++ b/camlp4/Makefile @@ -1,10 +1,10 @@ -# $Id: Makefile,v 1.20 2003/07/10 12:27:00 michel Exp $ +# $Id: Makefile,v 1.22.2.3 2004/07/07 16:41:58 mauny Exp $ include config/Makefile -DIRS=odyl camlp4 meta etc top ocpp lib man +DIRS=odyl camlp4 meta lib etc top ocpp man FDIRS=odyl camlp4 meta lib -OPTDIRS= lib odyl camlp4 meta compile +OPTDIRS=lib odyl camlp4 meta etc compile SHELL=/bin/sh COLD_FILES=ocaml_src/camlp4/argl.ml ocaml_src/camlp4/ast2pt.ml ocaml_src/camlp4/ast2pt.mli ocaml_src/camlp4/mLast.mli ocaml_src/camlp4/pcaml.ml ocaml_src/camlp4/pcaml.mli ocaml_src/camlp4/quotation.ml ocaml_src/camlp4/quotation.mli ocaml_src/camlp4/reloc.ml ocaml_src/camlp4/reloc.mli ocaml_src/camlp4/spretty.ml ocaml_src/camlp4/spretty.mli ocaml_src/lib/extfun.ml ocaml_src/lib/extfun.mli ocaml_src/lib/fstream.ml ocaml_src/lib/fstream.mli ocaml_src/lib/gramext.ml ocaml_src/lib/gramext.mli ocaml_src/lib/grammar.ml ocaml_src/lib/grammar.mli ocaml_src/lib/plexer.ml ocaml_src/lib/plexer.mli ocaml_src/lib/stdpp.ml ocaml_src/lib/stdpp.mli ocaml_src/lib/token.ml ocaml_src/lib/token.mli ocaml_src/meta/pa_extend.ml ocaml_src/meta/pa_extend_m.ml ocaml_src/meta/pa_macro.ml ocaml_src/meta/pa_r.ml ocaml_src/meta/pa_rp.ml ocaml_src/meta/pr_dump.ml ocaml_src/meta/q_MLast.ml ocaml_src/odyl/odyl_main.ml ocaml_src/odyl/odyl_main.mli ocaml_src/odyl/odyl.ml @@ -130,6 +130,27 @@ 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; \ + cp ../../$$i/.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 + +my_bootstrap_sources: mkdir ocaml_src.new @-for i in $(FDIRS); do \ (mkdir ocaml_src.new/$$i; cd ocaml_src.new/$$i; \ @@ -146,7 +167,7 @@ bootstrap_sources: for j in *.ml*; do \ echo ============================================; \ echo ocaml_src.new/$$i/$$j; \ - OTOP=../.. ../tools/conv.sh $$j | \ + $$HOME/bin/conv.sh $$j | \ sed 's/$$Id.*\$$/$(TXTGEN)/' > \ ../ocaml_src.new/$$i/$$j; \ done); \ diff --git a/camlp4/Makefile.Mac b/camlp4/Makefile.Mac deleted file mode 100644 index 010895d3..00000000 --- a/camlp4/Makefile.Mac +++ /dev/null @@ -1,204 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: 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/camlp4/.depend b/camlp4/camlp4/.depend index 00ddb5ad..3c0f8e10 100644 --- a/camlp4/camlp4/.depend +++ b/camlp4/camlp4/.depend @@ -7,14 +7,12 @@ 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 + pcaml.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 -crc.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi -crc.cmx: $(OTOP)/otherlibs/dynlink/dynlink.cmx -pcaml.cmo: ast2pt.cmi mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmx: ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi + pcaml.cmx ast2pt.cmi +pcaml.cmo: mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi +pcaml.cmx: mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi quotation.cmo: mLast.cmi quotation.cmi quotation.cmx: mLast.cmi quotation.cmi reloc.cmo: mLast.cmi reloc.cmi diff --git a/camlp4/camlp4/Makefile b/camlp4/camlp4/Makefile index 7bde12fb..40b3dae4 100644 --- a/camlp4/camlp4/Makefile +++ b/camlp4/camlp4/Makefile @@ -1,4 +1,4 @@ -# $Id: Makefile,v 1.19 2003/08/29 12:15:14 xleroy Exp $ +# $Id: Makefile,v 1.20.2.5 2004/07/09 15:31:39 mauny Exp $ include ../config/Makefile @@ -9,8 +9,8 @@ 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 +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 spretty.cmo reloc.cmo pcaml.cmo ast2pt.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 spretty.cmx reloc.cmx pcaml.cmx ast2pt.cmx argl.cmx OBJS=../odyl/odyl.cma camlp4.cma CAMLP4M= @@ -18,23 +18,35 @@ CAMLP4=camlp4$(EXE) CAMLP4OPT=phony all: $(CAMLP4) -opt: $(OBJS:.cma=.cmxa) + +opt: opt$(PROFILING) + +optnoprof: $(OBJS:.cma=.cmxa) + +optprof: optnoprof $(OBJS:.cma=.p.cmxa) + optp4: $(CAMLP4OPT) $(CAMLP4): $(OBJS) ../odyl/odyl.cmo - $(OCAMLC) $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo -linkall -o $(CAMLP4) + $(OCAMLC) -linkall -o $@ $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo $(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx - $(OCAMLOPT) $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx -linkall -o $(CAMLP4OPT) + $(OCAMLOPT) -o $@ $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx $(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml - $(OCAMLOPT) -c $(OTOP)/utils/config.ml + $(OCAMLOPT) -I $(OTOP)/utils -c $(OTOP)/utils/config.ml + +$(OTOP)/utils/config.p.cmx: $(OTOP)/utils/config.ml + $(OCAMLOPT) -I $(OTOP)/utils -p -c -o $@ $(OTOP)/utils/config.ml camlp4.cma: $(CAMLP4_OBJS) - $(OCAMLC) $(LINKFLAGS) $(CAMLP4_OBJS) -a -o camlp4.cma + $(OCAMLC) $(LINKFLAGS) -a -o $@ $(CAMLP4_OBJS) camlp4.cmxa: $(CAMLP4_XOBJS) - $(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa + $(OCAMLOPT) $(LINKFLAGS) -a -o $@ $(CAMLP4_XOBJS) + +camlp4.p.cmxa: $(CAMLP4_XOBJS:.cmx=.p.cmx) + $(OCAMLOPT) $(LINKFLAGS) -a -o $@ $(CAMLP4_XOBJS:.cmx=.p.cmx) clean:: rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt @@ -63,9 +75,8 @@ install: cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/." cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/." cp camlp4.cma $(LIBDIR)/camlp4/. - if [ -f camlp4.cmxa ]; \ - then cp camlp4.cmxa camlp4.$(A) $(LIBDIR)/camlp4/.; \ - else : ; \ - fi + for f in camlp4.$(A) camlp4.p.$(A) camlp4.cmxa camlp4.p.cmxa; do \ + test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true; \ + done include .depend diff --git a/camlp4/camlp4/Makefile.Mac b/camlp4/camlp4/Makefile.Mac deleted file mode 100644 index 7e1b4e0c..00000000 --- a/camlp4/camlp4/Makefile.Mac +++ /dev/null @@ -1,69 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: 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 deleted file mode 100644 index 3665195f..00000000 --- a/camlp4/camlp4/Makefile.Mac.depend +++ /dev/null @@ -1,15 +0,0 @@ -pcaml.cmiÄ mLast.cmi spretty.cmi -quotation.cmiÄ mLast.cmi -reloc.cmiÄ mLast.cmi -argl.cmoÄ ast2pt.cmo mLast.cmi pcaml.cmi -argl.cmxÄ ast2pt.cmx mLast.cmi pcaml.cmx -ast2pt.cmoÄ mLast.cmi -ast2pt.cmxÄ mLast.cmi -pcaml.cmoÄ ast2pt.cmo mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmxÄ ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi -quotation.cmoÄ mLast.cmi quotation.cmi -quotation.cmxÄ mLast.cmi quotation.cmi -reloc.cmoÄ mLast.cmi reloc.cmi -reloc.cmxÄ mLast.cmi reloc.cmi -spretty.cmoÄ spretty.cmi -spretty.cmxÄ spretty.cmi diff --git a/camlp4/camlp4/argl.ml b/camlp4/camlp4/argl.ml index f822ff8e..febbf752 100644 --- a/camlp4/camlp4/argl.ml +++ b/camlp4/camlp4/argl.ml @@ -1,5 +1,5 @@ (* camlp4r q_MLast.cmo *) -(* $Id: argl.ml,v 1.12 2003/07/10 12:28:14 michel Exp $ *) +(* $Id: argl.ml,v 1.14.2.1 2004/06/25 07:08:00 mauny Exp $ *) open Printf; @@ -123,7 +123,7 @@ 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) + else eprintf "At location %d-%d\n" (fst loc).Lexing.pos_cnum (snd loc).Lexing.pos_cnum ; value print_warning loc s = @@ -216,6 +216,12 @@ value file_kind_of_name name = else raise (Arg.Bad ("don't know what to do with " ^ name)) ; +value print_version_string () = + do { + print_string Pcaml.version; print_newline(); exit 0 + } +; + value print_version () = do { eprintf "Camlp4 version %s\n" Pcaml.version; flush stderr; exit 0 @@ -343,7 +349,10 @@ value initial_spec_list = ("-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.")] + "Print Camlp4 version and exit."); + ("-version", Arg.Unit print_version_string, + "Print Camlp4 version number and exit.") + ] ; value anon_fun x = @@ -415,7 +424,7 @@ value go () = report_error exc; Format.close_box (); Format.print_newline (); - exit 2 + raise exc } } ; diff --git a/camlp4/camlp4/ast2pt.ml b/camlp4/camlp4/ast2pt.ml index d47062a5..e9eba001 100644 --- a/camlp4/camlp4/ast2pt.ml +++ b/camlp4/camlp4/ast2pt.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ast2pt.ml,v 1.26 2003/09/30 14:39:26 mauny Exp $ *) +(* $Id: ast2pt.ml,v 1.31 2004/05/25 11:38:31 mauny Exp $ *) open Stdpp; open MLast; @@ -19,7 +19,7 @@ open Longident; open Asttypes; value fast = ref False; -value no_constructors_arity = ref False; +value no_constructors_arity = Pcaml.no_constructors_arity; value get_tag x = if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x @@ -32,30 +32,42 @@ value char_of_char_token loc s = ; value string_of_string_token loc s = - try Token.eval_string s with [ Failure _ as exn -> raise_with_loc loc exn ] + try Token.eval_string loc s + with [ Failure _ as exn -> raise_with_loc loc exn ] ; value glob_fname = ref ""; value mkloc (bp, ep) = - let loc_at n = { - Lexing.pos_fname = glob_fname.val; - Lexing.pos_lnum = 1; (* ddr met -1 ici ??? *) - Lexing.pos_bol = 0; - Lexing.pos_cnum = n + let loc_at n = + { (n) with + Lexing.pos_fname = + if n.Lexing.pos_fname = "" then + if glob_fname.val = "" then + Pcaml.input_file.val + else + glob_fname.val + else + n.Lexing.pos_fname } in {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; - Location.loc_ghost = False} (* ddr met: bp = 0 && ep = 0 *) + Location.loc_ghost = + bp.Lexing.pos_cnum = 0 && ep.Lexing.pos_cnum = 0} ; value mkghloc (bp, ep) = - let loc_at n = { - Lexing.pos_fname = ""; - Lexing.pos_lnum = 1; - Lexing.pos_bol = 0; - Lexing.pos_cnum = n + let loc_at n = + { (n) with + Lexing.pos_fname = + if n.Lexing.pos_fname = "" then + if glob_fname.val = "" then + Pcaml.input_file.val + else + glob_fname.val + else + n.Lexing.pos_fname } in {Location.loc_start = loc_at bp; @@ -130,22 +142,37 @@ value rec ctyp_fa al = | f -> (f, al) ] ; -value rec ctyp_long_id = - fun +value rec ctyp_long_id_prefix t = + match t with [ TyAcc _ m (TyLid _ s) -> - let (is_cls, li) = ctyp_long_id m in - (is_cls, ldot li s) + error (loc_of_ctyp t) "invalid module expression" | TyAcc _ m (TyUid _ s) -> - let (is_cls, li) = ctyp_long_id m in + let (is_cls, li) = ctyp_long_id_prefix 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 + let (is_cls, li1) = ctyp_long_id_prefix m1 in + let (_, li2) = ctyp_long_id_prefix m2 in (is_cls, Lapply li1 li2) | TyUid _ s -> (False, lident s) + | TyLid _ s -> + error (loc_of_ctyp t) "invalid module expression" + | t -> error (loc_of_ctyp t) "invalid module expression" ] +; + +value ctyp_long_id t = + match t with + [ TyAcc _ m (TyLid _ s) -> + let (is_cls, li) = ctyp_long_id_prefix m in + (is_cls, ldot li s) + | TyAcc _ m (TyUid _ s as t) -> + error (loc_of_ctyp t) "invalid type name" + | TyApp _ m1 m2 -> + error (loc_of_ctyp t) "invalid type name" + | TyUid _ s -> + error (loc_of_ctyp t) "invalid type name" | TyLid _ s -> (False, lident s) | TyCls loc sl -> (True, long_id_of_string_list loc sl) - | t -> error (loc_of_ctyp t) "incorrect type" ] + | t -> error (loc_of_ctyp t) "invalid type" ] ; value rec ctyp = @@ -159,7 +186,7 @@ value rec ctyp = match (t1, t2) with [ (t, TyQuo _ s) -> (t, s) | (TyQuo _ s, t) -> (t, s) - | _ -> error loc "incorrect alias type" ] + | _ -> error loc "invalid alias type" ] in mktyp loc (Ptyp_alias (ctyp t) i) | TyAny loc -> mktyp loc Ptyp_any @@ -186,7 +213,7 @@ value rec ctyp = | 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) []) + | TyUid loc s as t -> error (loc_of_ctyp t) "invalid type" | TyVrn loc catl ool -> let catl = List.map @@ -390,7 +417,7 @@ value rec patt = match (p1, p2) with [ (p, PaLid _ s) -> (p, s) | (PaLid _ s, p) -> (p, s) - | _ -> error loc "incorrect alias pattern" ] + | _ -> error loc "invalid alias pattern" ] in mkpat loc (Ppat_alias (patt p) i) | PaAnt _ p -> patt p @@ -614,6 +641,14 @@ value rec expr = | 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)) + | ExObj 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 + mkexp loc (Pexp_object (patt p, cil)) | ExOlb loc _ _ -> error loc "labeled expression not allowed here" | ExOvr loc iel -> mkexp loc (Pexp_override (List.map mkideexp iel)) | ExRec loc lel eo -> diff --git a/camlp4/camlp4/ast2pt.mli b/camlp4/camlp4/ast2pt.mli index a981dfaf..74e559b7 100644 --- a/camlp4/camlp4/ast2pt.mli +++ b/camlp4/camlp4/ast2pt.mli @@ -10,12 +10,12 @@ (* *) (***********************************************************************) -(* $Id: ast2pt.mli,v 1.3 2002/07/19 14:53:44 mauny Exp $ *) +(* $Id: ast2pt.mli,v 1.4 2004/05/12 15:22:38 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 mkloc : MLast.loc -> Location.t; +value long_id_of_string_list : MLast.loc -> list string -> Longident.t; value str_item : MLast.str_item -> Parsetree.structure -> Parsetree.structure; value interf : list MLast.sig_item -> Parsetree.signature; diff --git a/camlp4/camlp4/mLast.mli b/camlp4/camlp4/mLast.mli index c783ef12..91387240 100644 --- a/camlp4/camlp4/mLast.mli +++ b/camlp4/camlp4/mLast.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: mLast.mli,v 1.15 2003/07/16 12:50:07 mauny Exp $ *) +(* $Id: mLast.mli,v 1.17 2004/05/19 15:00:45 mauny Exp $ *) (* Module [MLast]: abstract syntax tree @@ -19,7 +19,7 @@ these values in concrete syntax (see the Camlp4 documentation). See also the file q_MLast.ml in Camlp4 sources. *) -type loc = (int * int); +type loc = (Lexing.position * Lexing.position); type ctyp = [ TyAcc of loc and ctyp and ctyp @@ -104,6 +104,7 @@ and expr = | 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 + | ExObj of loc and option patt and list class_str_item | 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 diff --git a/camlp4/camlp4/pcaml.ml b/camlp4/camlp4/pcaml.ml index 3420822c..d4776538 100644 --- a/camlp4/camlp4/pcaml.ml +++ b/camlp4/camlp4/pcaml.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pcaml.ml,v 1.12 2003/07/10 12:28:14 michel Exp $ *) +(* $Id: pcaml.ml,v 1.13.2.2 2004/06/25 07:08:00 mauny Exp $ *) value version = Sys.ocaml_version; @@ -58,7 +58,10 @@ 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 } + let c1 = bp.Lexing.pos_cnum - bp.Lexing.pos_bol in + let c2 = ep.Lexing.pos_cnum - bp.Lexing.pos_bol in + do { Printf.eprintf " File \"%s\", line %d, chars %d-%d: %s\n" + bp.Lexing.pos_fname bp.Lexing.pos_lnum c1 c2 txt; flush stderr } ; value warning = ref warning_default_function; @@ -82,21 +85,21 @@ List.iter (fun (n, f) -> Quotation.add n f) value quotation_dump_file = ref (None : option string); type err_ctx = - [ Finding | Expanding | ParsingResult of (int * int) and string | Locating ] + [ Finding | Expanding | ParsingResult of MLast.loc 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 + fun (bp, ep) txt -> warn (Reloc.adjust_loc shift (bp, ep)) txt in apply_with_var warning new_warning (fun () -> try expander str with - [ Stdpp.Exc_located (p1, p2) exc -> + [ Stdpp.Exc_located loc exc -> let exc1 = Qerror name Expanding exc in - raise (Stdpp.Exc_located (shift + p1, shift + p2) exc1) + raise (Stdpp.Exc_located (Reloc.adjust_loc shift (Reloc.linearize loc)) exc1) | exc -> let exc1 = Qerror name Expanding exc in raise (Stdpp.Exc_located loc exc1) ]) @@ -106,7 +109,7 @@ 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) + raise (Stdpp.Exc_located (Reloc.adjust_loc shift iloc) exc) | Stdpp.Exc_located iloc (Qerror _ Expanding exc) -> let ctx = ParsingResult iloc str in let exc1 = Qerror name ctx exc in @@ -119,18 +122,22 @@ value parse_quotation_result entry loc shift name str = raise (Stdpp.Exc_located loc exc1) ] ; +value ghostify (bp, ep) = + let ghost p = { (p) with Lexing.pos_cnum = 0 } in + (ghost bp, ghost ep) +; + 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 shift = Reloc.shift_pos shift (fst loc) 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) + raise (Stdpp.Exc_located (fst loc, shift) exc1) in let ast = match expander with @@ -140,7 +147,14 @@ value handle_quotation loc proj in_expr entry reloc (name, str) = | Quotation.ExAst fe_fp -> expand_quotation loc (proj fe_fp) shift name str ] in - reloc (fun _ -> loc) shift ast + (* Warning: below, we use a side-effecting function that produces a real location + on its first call, and ghost ones at subsequent calls. *) + reloc + (let zero = ref None in + fun _ -> match zero.val with [ + None -> do { zero.val := Some (ghostify loc) ; loc } + | Some x -> x ]) + shift ast ; value parse_locate entry shift str = @@ -149,12 +163,12 @@ value parse_locate entry shift str = [ 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) ] + raise (Stdpp.Exc_located (Reloc.adjust_loc shift (p1, p2)) exc1) ] ; value handle_locate loc entry ast_f (pos, str) = let s = str in - let loc = (pos, pos + String.length s) in + let loc = (pos, Reloc.shift_pos (String.length s) pos) in let x = parse_locate entry (fst loc) s in ast_f loc x ; @@ -187,14 +201,22 @@ 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 module_type_reloc = Reloc.module_type; +value sig_item_reloc = Reloc.sig_item; +value with_constr_reloc = Reloc.with_constr; +value module_expr_reloc = Reloc.module_expr; +value str_item_reloc = Reloc.str_item; +value class_type_reloc = Reloc.class_type; +value class_sig_item_reloc = Reloc.class_sig_item; +value class_expr_reloc = Reloc.class_expr; +value class_str_item_reloc = Reloc.class_str_item; + value rename_id = ref (fun x -> x); value find_line (bp, ep) str = - 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) + (bp.Lexing.pos_lnum, + bp.Lexing.pos_cnum - bp.Lexing.pos_bol, + ep.Lexing.pos_cnum - bp.Lexing.pos_bol) ; value loc_fmt = @@ -355,8 +377,7 @@ value report_error exn = | e -> print_exn exn ] ; -value no_constructors_arity = Ast2pt.no_constructors_arity; -(*value no_assert = ref False;*) +value no_constructors_arity = ref False; value arg_spec_list_ref = ref []; value arg_spec_list () = arg_spec_list_ref.val; diff --git a/camlp4/camlp4/pcaml.mli b/camlp4/camlp4/pcaml.mli index 53f5310c..c0a1b70a 100644 --- a/camlp4/camlp4/pcaml.mli +++ b/camlp4/camlp4/pcaml.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pcaml.mli,v 1.6 2003/07/10 12:28:15 michel Exp $ *) +(* $Id: pcaml.mli,v 1.7.2.2 2004/06/25 07:08:01 mauny Exp $ *) (** Language grammar, entries and printers. @@ -76,22 +76,27 @@ 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_expr_locate : MLast.loc -> (Lexing.position * string) -> MLast.expr; value handle_patt_quotation : MLast.loc -> (string * string) -> MLast.patt; -value handle_patt_locate : MLast.loc -> (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; +value handle_patt_locate : MLast.loc -> (Lexing.position * string) -> MLast.patt; + +(** Relocation functions for abstract syntax trees *) +value expr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr; +value patt_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt; +value module_type_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type -> MLast.module_type; +value sig_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item -> MLast.sig_item; +value with_constr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr -> MLast.with_constr; +value module_expr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr -> MLast.module_expr; +value str_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item -> MLast.str_item; +value class_type_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type -> MLast.class_type; +value class_sig_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item -> MLast.class_sig_item; +value class_expr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr -> MLast.class_expr; +value class_str_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item -> MLast.class_str_item; (** To possibly rename identifiers; parsers may call this function when generating their identifiers; default = identity *) @@ -99,7 +104,7 @@ 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 ] + [ Finding | Expanding | ParsingResult of MLast.loc and string | Locating ] ; exception Qerror of string and err_ctx and exn; @@ -151,7 +156,8 @@ value inter_phrases : ref (option string); (* for system use *) -value warning : ref ((int * int) -> string -> unit); +value warning : ref (MLast.loc -> 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); +value no_constructors_arity : ref bool; diff --git a/camlp4/camlp4/reloc.ml b/camlp4/camlp4/reloc.ml index 6678a1af..913fdb46 100644 --- a/camlp4/camlp4/reloc.ml +++ b/camlp4/camlp4/reloc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: reloc.ml,v 1.14 2003/07/16 12:50:07 mauny Exp $ *) +(* $Id: reloc.ml,v 1.16 2004/05/19 15:00:45 mauny Exp $ *) open MLast; @@ -61,136 +61,229 @@ value class_infos a floc sh x = ciNam = x.ciNam; ciExp = a floc sh x.ciExp} ; +(* Debugging positions and locations *) +value eprint_pos msg p = + Printf.eprintf "%s: fname=%s; lnum=%d; bol=%d; cnum=%d\n%!" + msg p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum +; + +value eprint_loc (bp, ep) = + do { eprint_pos " P1" bp; eprint_pos " P2" ep } +; + +value check_position msg p = + let ok = + if (p.Lexing.pos_lnum < 0 || + p.Lexing.pos_bol < 0 || + p.Lexing.pos_cnum < 0 || + p.Lexing.pos_cnum < p.Lexing.pos_bol) + then + do { + Printf.eprintf "*** Warning: (%s) strange position ***\n" msg; + eprint_pos msg p; + False + } + else + True in + (ok, p) +; + +value check_location msg ((bp, ep) as loc) = + let ok = + let (ok1,_) = check_position " From: " bp in + let (ok2,_) = check_position " To: " ep in + if ((not ok1) || (not ok2) || + bp.Lexing.pos_lnum > ep.Lexing.pos_lnum || + bp.Lexing.pos_bol > ep.Lexing.pos_bol || + bp.Lexing.pos_cnum > ep.Lexing.pos_cnum) + then + do { + Printf.eprintf "*** Warning: (%s) strange location ***\n" msg; + eprint_loc loc; + False + } + else + True in + (ok, loc) +; + +(* Change a location into linear positions *) +value linearize (bp, ep) = + ( { (bp) with Lexing.pos_lnum = 1; Lexing.pos_bol = 0 }, + { (ep) with Lexing.pos_lnum = 1; Lexing.pos_bol = 0 }) +; + +value shift_pos n p = + { (p) with Lexing.pos_cnum = p.Lexing.pos_cnum + n } +; + +value zero_loc = + { (Lexing.dummy_pos) with Lexing.pos_cnum = 0; Lexing.pos_lnum = 0 }; + + +value adjust_pos globpos local_pos = +{ + Lexing.pos_fname = globpos.Lexing.pos_fname; + Lexing.pos_lnum = globpos.Lexing.pos_lnum + local_pos.Lexing.pos_lnum - 1; + Lexing.pos_bol = + if local_pos.Lexing.pos_lnum <= 1 then + globpos.Lexing.pos_bol + else + local_pos.Lexing.pos_bol + globpos.Lexing.pos_cnum; + Lexing.pos_cnum = local_pos.Lexing.pos_cnum + globpos.Lexing.pos_cnum +}; + +value adjust_loc gpos (p1, p2) = + (adjust_pos gpos p1, adjust_pos gpos p2) +; + +(* Note: in the following, the "let nloc = floc loc in" is necessary + in order to force evaluation order: the "floc" function has a side-effect + that changes all locations produced but the first one into ghost locations *) + 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 + [ PaAcc loc x1 x2 -> let nloc = floc loc in PaAcc nloc (self x1) (self x2) + | PaAli loc x1 x2 -> let nloc = floc loc in PaAli nloc (self x1) (self x2) + | PaAnt loc x1 -> (* Note that antiquotations are parsed by the OCaml parser, passing line numbers and begs of lines *) + patt (fun lloc -> adjust_loc (adjust_pos sh (fst loc)) (linearize lloc)) zero_loc x1 + | PaAny loc -> let nloc = floc loc in PaAny nloc + | PaApp loc x1 x2 -> let nloc = floc loc in PaApp nloc (self x1) (self x2) + | PaArr loc x1 -> let nloc = floc loc in PaArr nloc (List.map self x1) + | PaChr loc x1 -> let nloc = floc loc in PaChr nloc x1 + | PaInt loc x1 -> let nloc = floc loc in PaInt nloc x1 + | PaInt32 loc x1 -> let nloc = floc loc in PaInt32 nloc x1 + | PaInt64 loc x1 -> let nloc = floc loc in PaInt64 nloc x1 + | PaNativeInt loc x1 -> let nloc = floc loc in PaNativeInt nloc x1 + | PaFlo loc x1 -> let nloc = floc loc in PaFlo nloc x1 + | PaLab loc x1 x2 -> let nloc = floc loc in PaLab nloc x1 (option_map self x2) + | PaLid loc x1 -> let nloc = floc loc in PaLid nloc x1 | PaOlb loc x1 x2 -> - PaOlb (floc loc) x1 + let nloc = floc loc in + PaOlb nloc 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) + | PaOrp loc x1 x2 -> let nloc = floc loc in PaOrp nloc (self x1) (self x2) + | PaRng loc x1 x2 -> let nloc = floc loc in PaRng nloc (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 ] + let nloc = floc loc in PaRec nloc (List.map (fun (x1, x2) -> (self x1, self x2)) x1) + | PaStr loc x1 -> let nloc = floc loc in PaStr nloc x1 + | PaTup loc x1 -> let nloc = floc loc in PaTup nloc (List.map self x1) + | PaTyc loc x1 x2 -> let nloc = floc loc in PaTyc nloc (self x1) (ctyp floc sh x2) + | PaTyp loc x1 -> let nloc = floc loc in PaTyp nloc x1 + | PaUid loc x1 -> let nloc = floc loc in PaUid nloc x1 + | PaVrn loc x1 -> let nloc = floc loc in PaVrn nloc 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 + [ ExAcc loc x1 x2 -> let nloc = floc loc in ExAcc nloc (self x1) (self x2) + | ExAnt loc x1 -> (* Note that antiquotations are parsed by the OCaml parser, passing line numbers and begs of lines *) + expr (fun lloc -> (adjust_loc (adjust_pos sh (fst loc)) (linearize lloc))) + zero_loc x1 + | ExApp loc x1 x2 -> let nloc = floc loc in ExApp nloc (self x1) (self x2) + | ExAre loc x1 x2 -> let nloc = floc loc in ExAre nloc (self x1) (self x2) + | ExArr loc x1 -> let nloc = floc loc in ExArr nloc (List.map self x1) + | ExAsf loc -> let nloc = floc loc in ExAsf nloc + | ExAsr loc x1 -> let nloc = floc loc in ExAsr nloc (self x1) + | ExAss loc x1 x2 -> let nloc = floc loc in ExAss nloc (self x1) (self x2) + | ExChr loc x1 -> let nloc = floc loc in ExChr nloc x1 | ExCoe loc x1 x2 x3 -> - ExCoe (floc loc) (self x1) (option_map (ctyp floc sh) x2) + let nloc = floc loc in + ExCoe nloc (self x1) (option_map (ctyp floc sh) x2) (ctyp floc sh x3) - | ExFlo loc x1 -> ExFlo (floc loc) x1 + | ExFlo loc x1 -> let nloc = floc loc in ExFlo nloc x1 | ExFor loc x1 x2 x3 x4 x5 -> - ExFor (floc loc) x1 (self x2) (self x3) x4 (List.map self x5) + let nloc = floc loc in ExFor nloc x1 (self x2) (self x3) x4 (List.map self x5) | ExFun loc x1 -> - ExFun (floc loc) + let nloc = floc loc in + ExFun nloc (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) + | ExIfe loc x1 x2 x3 -> let nloc = floc loc in ExIfe nloc (self x1) (self x2) (self x3) + | ExInt loc x1 -> let nloc = floc loc in ExInt nloc x1 + | ExInt32 loc x1 -> let nloc = floc loc in ExInt32 nloc x1 + | ExInt64 loc x1 -> let nloc = floc loc in ExInt64 nloc x1 + | ExNativeInt loc x1 -> let nloc = floc loc in ExNativeInt nloc x1 + | ExLab loc x1 x2 -> let nloc = floc loc in ExLab nloc x1 (option_map self x2) + | ExLaz loc x1 -> let nloc = floc loc in ExLaz nloc (self x1) | ExLet loc x1 x2 x3 -> - ExLet (floc loc) x1 + let nloc = floc loc in + ExLet nloc x1 (List.map (fun (x1, x2) -> (patt floc sh x1, self x2)) x2) (self x3) - | ExLid loc x1 -> ExLid (floc loc) x1 + | ExLid loc x1 -> let nloc = floc loc in ExLid nloc x1 | ExLmd loc x1 x2 x3 -> - ExLmd (floc loc) x1 (module_expr floc sh x2) (self x3) + let nloc = floc loc in ExLmd nloc x1 (module_expr floc sh x2) (self x3) | ExMat loc x1 x2 -> - ExMat (floc loc) (self x1) + let nloc = floc loc in + ExMat nloc (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) + | ExNew loc x1 -> let nloc = floc loc in ExNew nloc x1 + | ExObj loc x1 x2 -> + let nloc = floc loc in ExObj nloc (option_map (patt floc sh) x1) + (List.map (class_str_item floc sh) x2) + | ExOlb loc x1 x2 -> let nloc = floc loc in ExOlb nloc x1 (option_map self x2) | ExOvr loc x1 -> - ExOvr (floc loc) (List.map (fun (x1, x2) -> (x1, self x2)) x1) + let nloc = floc loc in + ExOvr nloc (List.map (fun (x1, x2) -> (x1, self x2)) x1) | ExRec loc x1 x2 -> - ExRec (floc loc) + let nloc = floc loc in + ExRec nloc (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 + | ExSeq loc x1 -> let nloc = floc loc in ExSeq nloc (List.map self x1) + | ExSnd loc x1 x2 -> let nloc = floc loc in ExSnd nloc (self x1) x2 + | ExSte loc x1 x2 -> let nloc = floc loc in ExSte nloc (self x1) (self x2) + | ExStr loc x1 -> let nloc = floc loc in ExStr nloc x1 | ExTry loc x1 x2 -> - ExTry (floc loc) (self x1) + let nloc = floc loc in + ExTry nloc (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) ] + | ExTup loc x1 -> let nloc = floc loc in ExTup nloc (List.map self x1) + | ExTyc loc x1 x2 -> let nloc = floc loc in ExTyc nloc (self x1) (ctyp floc sh x2) + | ExUid loc x1 -> let nloc = floc loc in ExUid nloc x1 + | ExVrn loc x1 -> let nloc = floc loc in ExVrn nloc x1 + | ExWhi loc x1 x2 -> let nloc = floc loc in ExWhi nloc (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 + [ MtAcc loc x1 x2 -> let nloc = floc loc in MtAcc nloc (self x1) (self x2) + | MtApp loc x1 x2 -> let nloc = floc loc in MtApp nloc (self x1) (self x2) + | MtFun loc x1 x2 x3 -> let nloc = floc loc in MtFun nloc x1 (self x2) (self x3) + | MtLid loc x1 -> let nloc = floc loc in MtLid nloc x1 + | MtQuo loc x1 -> let nloc = floc loc in MtQuo nloc x1 + | MtSig loc x1 -> let nloc = floc loc in MtSig nloc (List.map (sig_item floc sh) x1) + | MtUid loc x1 -> let nloc = floc loc in MtUid nloc x1 | MtWit loc x1 x2 -> - MtWit (floc loc) (self x1) (List.map (with_constr floc sh) x2) ] + let nloc = floc loc in MtWit nloc (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) + let nloc = floc loc in SgCls nloc (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) + let nloc = floc loc in SgClt nloc (List.map (class_infos class_type floc sh) x1) + | SgDcl loc x1 -> let nloc = floc loc in SgDcl nloc (List.map self x1) + | SgDir loc x1 x2 -> let nloc = floc loc in SgDir nloc x1 x2 + | SgExc loc x1 x2 -> let nloc = floc loc in SgExc nloc x1 (List.map (ctyp floc sh) x2) + | SgExt loc x1 x2 x3 -> let nloc = floc loc in SgExt nloc x1 (ctyp floc sh x2) x3 + | SgInc loc x1 -> let nloc = floc loc in SgInc nloc (module_type floc sh x1) + | SgMod loc x1 x2 -> let nloc = floc loc in SgMod nloc 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 + -> let nloc = floc loc in SgRecMod nloc (List.map (fun (x1,x2) -> (x1, (module_type floc sh x2))) xxs) + | SgMty loc x1 x2 -> let nloc = floc loc in SgMty nloc x1 (module_type floc sh x2) + | SgOpn loc x1 -> let nloc = floc loc in SgOpn nloc x1 | SgTyp loc x1 -> - SgTyp (floc loc) + let nloc = floc loc in + SgTyp nloc (List.map (fun ((loc, x1), x2, x3, x4) -> ((floc loc, x1), x2, ctyp floc sh x3, @@ -198,42 +291,44 @@ and sig_item floc sh = x4)) x1) | SgUse loc x1 x2 -> SgUse loc x1 x2 - | SgVal loc x1 x2 -> SgVal (floc loc) x1 (ctyp floc sh x2) ] + | SgVal loc x1 x2 -> let nloc = floc loc in SgVal nloc 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) ] + [ WcTyp loc x1 x2 x3 -> let nloc = floc loc in WcTyp nloc x1 x2 (ctyp floc sh x3) + | WcMod loc x1 x2 -> let nloc = floc loc in WcMod nloc 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) + [ MeAcc loc x1 x2 -> let nloc = floc loc in MeAcc nloc (self x1) (self x2) + | MeApp loc x1 x2 -> let nloc = floc loc in MeApp nloc (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 ] + let nloc = floc loc in + MeFun nloc x1 (module_type floc sh x2) (self x3) + | MeStr loc x1 -> let nloc = floc loc in MeStr nloc (List.map (str_item floc sh) x1) + | MeTyc loc x1 x2 -> let nloc = floc loc in MeTyc nloc (self x1) (module_type floc sh x2) + | MeUid loc x1 -> let nloc = floc loc in MeUid nloc 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) + let nloc = floc loc in StCls nloc (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) + let nloc = floc loc in StClt nloc (List.map (class_infos class_type floc sh) x1) + | StDcl loc x1 -> let nloc = floc loc in StDcl nloc (List.map self x1) + | StDir loc x1 x2 -> let nloc = floc loc in StDir nloc x1 x2 + | StExc loc x1 x2 x3 -> let nloc = floc loc in StExc nloc x1 (List.map (ctyp floc sh) x2) x3 + | StExp loc x1 -> let nloc = floc loc in StExp nloc (expr floc sh x1) + | StExt loc x1 x2 x3 -> let nloc = floc loc in StExt nloc x1 (ctyp floc sh x2) x3 + | StInc loc x1 -> let nloc = floc loc in StInc nloc (module_expr floc sh x1) + | StMod loc x1 x2 -> let nloc = floc loc in StMod nloc 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 + let nloc = floc loc in StRecMod nloc (List.map (fun (n, mt, me) -> (n, module_type floc sh mt, module_expr floc sh me)) nmtmes) + | StMty loc x1 x2 -> let nloc = floc loc in StMty nloc x1 (module_type floc sh x2) + | StOpn loc x1 -> let nloc = floc loc in StOpn nloc x1 | StTyp loc x1 -> - StTyp (floc loc) + let nloc = floc loc in + StTyp nloc (List.map (fun ((loc, x1), x2, x3, x4) -> ((floc loc, x1), x2, ctyp floc sh x3, @@ -242,48 +337,50 @@ and str_item floc sh = x1) | StUse loc x1 x2 -> StUse loc x1 x2 | StVal loc x1 x2 -> - StVal (floc loc) x1 + let nloc = floc loc in StVal nloc 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) + [ CtCon loc x1 x2 -> let nloc = floc loc in CtCon nloc x1 (List.map (ctyp floc sh) x2) + | CtFun loc x1 x2 -> let nloc = floc loc in CtFun nloc (ctyp floc sh x1) (self x2) | CtSig loc x1 x2 -> - CtSig (floc loc) (option_map (ctyp floc sh) x1) + let nloc = floc loc in + CtSig nloc (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) ] + [ CgCtr loc x1 x2 -> let nloc = floc loc in CgCtr nloc (ctyp floc sh x1) (ctyp floc sh x2) + | CgDcl loc x1 -> let nloc = floc loc in CgDcl nloc (List.map (class_sig_item floc sh) x1) + | CgInh loc x1 -> let nloc = floc loc in CgInh nloc (class_type floc sh x1) + | CgMth loc x1 x2 x3 -> let nloc = floc loc in CgMth nloc x1 x2 (ctyp floc sh x3) + | CgVal loc x1 x2 x3 -> let nloc = floc loc in CgVal nloc x1 x2 (ctyp floc sh x3) + | CgVir loc x1 x2 x3 -> let nloc = floc loc in CgVir nloc 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) + [ CeApp loc x1 x2 -> let nloc = floc loc in CeApp nloc (self x1) (expr floc sh x2) + | CeCon loc x1 x2 -> let nloc = floc loc in CeCon nloc x1 (List.map (ctyp floc sh) x2) + | CeFun loc x1 x2 -> let nloc = floc loc in CeFun nloc (patt floc sh x1) (self x2) | CeLet loc x1 x2 x3 -> - CeLet (floc loc) x1 + let nloc = floc loc in + CeLet nloc 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) + let nloc = floc loc in CeStr nloc (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) ] + | CeTyc loc x1 x2 -> let nloc = floc loc in CeTyc nloc (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) + [ CrCtr loc x1 x2 -> let nloc = floc loc in CrCtr nloc (ctyp floc sh x1) (ctyp floc sh x2) + | CrDcl loc x1 -> let nloc = floc loc in CrDcl nloc (List.map (class_str_item floc sh) x1) + | CrInh loc x1 x2 -> let nloc = floc loc in CrInh nloc (class_expr floc sh x1) x2 + | CrIni loc x1 -> let nloc = floc loc in CrIni nloc (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) ] + let nloc = floc loc in CrMth nloc x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4) + | CrVal loc x1 x2 x3 -> let nloc = floc loc in CrVal nloc x1 x2 (expr floc sh x3) + | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ] ; diff --git a/camlp4/camlp4/reloc.mli b/camlp4/camlp4/reloc.mli index 2abd2525..d4be634f 100644 --- a/camlp4/camlp4/reloc.mli +++ b/camlp4/camlp4/reloc.mli @@ -10,7 +10,24 @@ (* *) (***********************************************************************) -(* $Id: reloc.mli,v 1.2 2002/07/19 14:53:44 mauny Exp $ *) +(* $Id: reloc.mli,v 1.3.2.2 2004/07/08 08:50:12 mauny Exp $ *) -value patt : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt; -value expr : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr; +value zero_loc : Lexing.position; +value shift_pos : int -> Lexing.position -> Lexing.position; +value adjust_loc : Lexing.position -> MLast.loc -> MLast.loc; +value linearize : MLast.loc -> MLast.loc; + +value ctyp : (MLast.loc -> MLast.loc) -> 'a -> MLast.ctyp -> MLast.ctyp; +value row_field : (MLast.loc -> MLast.loc) -> 'a -> MLast.row_field -> MLast.row_field; +value class_infos : ((MLast.loc -> MLast.loc) -> 'a -> 'b -> 'c) -> (MLast.loc -> MLast.loc) -> 'a -> MLast.class_infos 'b -> MLast.class_infos 'c; +value patt : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt; +value expr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr; +value module_type : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type -> MLast.module_type; +value sig_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item -> MLast.sig_item; +value with_constr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr -> MLast.with_constr; +value module_expr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr -> MLast.module_expr; +value str_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item -> MLast.str_item; +value class_type : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type -> MLast.class_type; +value class_sig_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item -> MLast.class_sig_item; +value class_expr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr -> MLast.class_expr; +value class_str_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item -> MLast.class_str_item; diff --git a/camlp4/compile/.depend b/camlp4/compile/.depend index 707bed8f..c2cf6345 100644 --- a/camlp4/compile/.depend +++ b/camlp4/compile/.depend @@ -1,3 +1,5 @@ +comp_trail.cmo: ../camlp4/pcaml.cmi +comp_trail.cmx: ../camlp4/pcaml.cmx compile.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi compile.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_o_fast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi diff --git a/camlp4/compile/Makefile b/camlp4/compile/Makefile index 9b14f3ac..5b256e2a 100644 --- a/camlp4/compile/Makefile +++ b/camlp4/compile/Makefile @@ -1,4 +1,4 @@ -# $Id: Makefile,v 1.8 2003/08/29 12:15:14 xleroy Exp $ +# $Id: Makefile,v 1.8.4.1 2004/06/23 11:54:57 mauny Exp $ include ../config/Makefile @@ -29,7 +29,8 @@ $D_fast.ml: compile.cmo $(SRC) OTOP=$(OTOP) EXE=$(EXE) ./compile.sh $(COMP_OPT) $(SRC) > $D_fast.ml install: - if test -f camlp4o.fast.opt; then cp camlp4o.fast.opt $(BINDIR)/camlp4o.opt$(EXE); fi + if test -f camlp4$D.fast.opt; then cp camlp4$D.fast.opt $(BINDIR)/camlp4$D.opt$(EXE); fi + for TARG in pa_$D_fast.cmi pa_$D_fast.cmo pa_$D_fast.cmx ; do if test -f $$TARG; then cp $$TARG "$(LIBDIR)/camlp4/."; fi; done clean:: rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt diff --git a/camlp4/compile/comp_trail.ml b/camlp4/compile/comp_trail.ml index 74c34b15..75f40abb 100644 --- a/camlp4/compile/comp_trail.ml +++ b/camlp4/compile/comp_trail.ml @@ -1,4 +1,4 @@ - +(* camlp4r pa_extend.cmo *) (****************************************) value interf_p = diff --git a/camlp4/compile/compile.ml b/camlp4/compile/compile.ml index fd245d9e..45d7c6b3 100644 --- a/camlp4/compile/compile.ml +++ b/camlp4/compile/compile.ml @@ -1,5 +1,5 @@ (* camlp4r *) -(* $Id: compile.ml,v 1.12 2003/07/10 12:28:15 michel Exp $ *) +(* $Id: compile.ml,v 1.13 2004/05/12 15:22:39 mauny Exp $ *) #load "q_MLast.cmo"; @@ -8,7 +8,10 @@ open Gramext; value strict_parsing = ref False; value keywords = ref []; -value loc = (0, 0); +value loc = + let nowhere = + {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in + (nowhere,nowhere); (* Watch the segmentation faults here! the compiled file must have been loaded in camlp4 with the option pa_extend.cmo -meta_action. *) @@ -101,7 +104,7 @@ value nth_patt_of_act (e, n) = let patt_list = loop e where rec loop = fun - [ <:expr< fun (loc : (int * int)) -> $_$ >> -> [] + [ <:expr< fun (loc : (Lexing.position * Lexing.position)) -> $_$ >> -> [] | <:expr< fun ($p$ : $_$) -> $e$ >> -> [p :: loop e] | <:expr< fun $p$ -> $e$ >> -> [p :: loop e] | _ -> failwith "nth_patt_of_act" ] @@ -111,14 +114,14 @@ value nth_patt_of_act (e, n) = value rec last_patt_of_act = fun - [ <:expr< fun ($p$ : $_$) (loc : (int * int)) -> $_$ >> -> p + [ <:expr< fun ($p$ : $_$) (loc : (Lexing.position * Lexing.position)) -> $_$ >> -> 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 (loc : (Lexing.position * Lexing.position)) -> ($e$ : $_$) >> -> e | <:expr< fun $_$ -> $e$ >> -> final_action e | _ -> failwith "final_action" ] ; @@ -560,7 +563,10 @@ value compile () = $expr_list list$ >> in - let loc = (1, 1) in + let loc = + let l1 = + {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 1 } in + (l1,l1) in ([(si1, loc); (si2, loc)], False) ; diff --git a/camlp4/config/Makefile.tpl b/camlp4/config/Makefile.tpl index f5798fa5..63c0213c 100644 --- a/camlp4/config/Makefile.tpl +++ b/camlp4/config/Makefile.tpl @@ -1,4 +1,16 @@ -# $Id: Makefile.tpl,v 1.4 2001/09/09 08:22:46 ddr Exp $ +# $Id: Makefile.tpl,v 1.4.10.6 2004/07/03 16:53:45 mauny Exp $ + +# Change the value of PROFILING to prof for systematically building +# and installing profiled versions of Camlp4 libraries. Then, execute +# `make opt.opt', then `make install' in the OCaml toplevel directory +# (or in the camlp4 subdirectory). + +# Default value is noprof + +#PROFILING=prof +PROFILING=noprof + +########################################################################### CAMLP4_COMM=OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/camlp4_comm.sh OCAMLC=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlc.sh @@ -6,23 +18,31 @@ OCAMLOPT=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlopt.sh OCAMLCFLAGS= MKDIR=mkdir -p -.SUFFIXES: .cmx .cmo .cmi .ml .mli +TEST_DIRECTORY=test `basename "$<"` = "$<" || { echo "You are not in the right directory"; exit 1; } + +.SUFFIXES: .cmx .cmo .cmi .ml .mli .p.cmx .mli.cmi: - @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi + @$(TEST_DIRECTORY) @$(CAMLP4_COMM) $< -o $*.ppi $(OCAMLC) $(OCAMLCFLAGS) -c -intf $*.ppi rm -f $*.ppi .ml.cmo: - @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi + @$(TEST_DIRECTORY) @$(CAMLP4_COMM) $< -o $*.ppo $(OCAMLC) $(OCAMLCFLAGS) -c -impl $*.ppo rm -f $*.ppo .ml.cmx: - @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi + @$(TEST_DIRECTORY) @$(CAMLP4_COMM) $< -o $*.ppo $(OCAMLOPT) $(OCAMLCFLAGS) -c -impl $*.ppo rm -f $*.ppo +.ml.p.cmx: + @$(TEST_DIRECTORY) + @$(CAMLP4_COMM) $< -o $*.ppo + $(OCAMLOPT) $(OCAMLCFLAGS) -c -p -o $*.p.cmx -impl $*.ppo + rm -f $*.ppo + diff --git a/camlp4/etc/.depend b/camlp4/etc/.depend index 63497262..482bb10c 100644 --- a/camlp4/etc/.depend +++ b/camlp4/etc/.depend @@ -3,40 +3,18 @@ pa_extfold.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_extfold.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_extfun.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_extfun.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_format.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_format.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_fstream.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_fstream.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_lefteval.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_lefteval.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_lisp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_lisp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_lispr.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_lispr.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_o.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_o.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_ocamllex.cmo: $(OTOP)/lex/compact.cmi $(OTOP)/lex/cset.cmi \ - $(OTOP)/lex/lexgen.cmi ../camlp4/mLast.cmi ../camlp4/pcaml.cmi \ - $(OTOP)/lex/syntax.cmi -pa_ocamllex.cmx: $(OTOP)/lex/compact.cmx $(OTOP)/lex/cset.cmx \ - $(OTOP)/lex/lexgen.cmx ../camlp4/mLast.cmi ../camlp4/pcaml.cmx \ - $(OTOP)/lex/syntax.cmx -pa_olabl.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_olabl.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_oop.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_oop.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_ru.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_ru.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_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 parserify.cmo: ../camlp4/mLast.cmi parserify.cmi parserify.cmx: ../camlp4/mLast.cmi parserify.cmi pr_depend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi @@ -63,11 +41,5 @@ pr_rp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ ../camlp4/spretty.cmi pr_rp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ ../camlp4/spretty.cmx -pr_scheme.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pr_scheme.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_schp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ - pr_scheme.cmo -pr_schp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ - pr_scheme.cmx q_phony.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi q_phony.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx diff --git a/camlp4/etc/Makefile b/camlp4/etc/Makefile index 7fa6fbab..1dc115c1 100644 --- a/camlp4/etc/Makefile +++ b/camlp4/etc/Makefile @@ -1,18 +1,17 @@ -# $Id: Makefile,v 1.15 2003/08/29 12:15:15 xleroy Exp $ +# $Id: Makefile,v 1.20.2.2 2004/07/07 16:22:23 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 +OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo + OBJSX=$(OBJS:.cmo=.cmx) INTF=pa_o.cmi CAMLP4OM=pa_o.cmo pa_op.cmo ../meta/pr_dump.cmo -#CAMLP4OMX=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) +COUT=$(OBJS) camlp4o$(EXE) COPT=$(OBJSX) camlp4o.opt all: $(COUT) mkcamlp4.sh @@ -24,17 +23,20 @@ pr_rp.cmo: parserify.cmo pr_rp_main.cmo pr_op.cmo: parserify.cmo pr_op_main.cmo $(OCAMLC) parserify.cmo pr_op_main.cmo -a -o $@ -pr_schemep.cmo: parserify.cmo pr_schp_main.cmo - $(OCAMLC) parserify.cmo pr_schp_main.cmo -a -o $@ +pr_rp.cmx: parserify.cmx pr_rp_main.cmx + $(OCAMLOPT) parserify.cmx pr_rp_main.cmx -a -o pr_rp.cmxa + mv pr_rp.cmxa pr_rp.cmx + mv pr_rp.$(A) pr_rp.$(O) + +pr_op.cmx: parserify.cmx pr_op_main.cmx + $(OCAMLOPT) parserify.cmx pr_op_main.cmx -a -o pr_op.cmxa + mv pr_op.cmxa pr_op.cmx + mv pr_op.$(A) pr_op.$(O) 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)" @@ -42,18 +44,6 @@ camlp4o.opt: $(CAMLP4OMX) mkcamlp4.sh: mkcamlp4.sh.tpl sed -e "s!LIBDIR!$(LIBDIR)!g" mkcamlp4.sh.tpl > mkcamlp4.sh -pa_ocamllex.cma: pa_ocamllex.cmo - $(OCAMLC) -I $(OTOP)/lex cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma - -bootstrap_scheme: - @$(MAKE) bootstrap_l L=scheme | grep -v directory -compare_scheme: - @$(MAKE) compare_l L=scheme | grep -v directory -bootstrap_lisp: - @$(MAKE) bootstrap_l L=lisp | grep -v directory -compare_lisp: - @$(MAKE) compare_l L=lisp | grep -v directory - bootstrap_l: ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml > tmp mv pa_$Lr.ml pa_$Lr.ml.old @@ -64,7 +54,7 @@ compare_l: ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' | diff -c pa_$Lr.ml - clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt + rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt rm -f mkcamlp4.sh camlp4o$(EXE) camlp4sch$(EXE) depend: @@ -81,15 +71,17 @@ install: -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" cp $(OBJS) "$(LIBDIR)/camlp4/." cp $(INTF) "$(LIBDIR)/camlp4/." - cp lib.sml "$(LIBDIR)/camlp4/." - cp camlp4o$(EXE) camlp4sch$(EXE) "$(BINDIR)/." - if test -f camlp4o.opt; then cp camlp4o.opt "$(BINDIR)/camlp4o.opt$(EXE)"; cp $(OBJSX) $(OBJSX:.cmx=.o) "$(LIBDIR)/camlp4/."; fi + cp camlp4o$(EXE) "$(BINDIR)/." + if test -f camlp4o.opt; then \ + cp camlp4o.opt "$(BINDIR)/camlp4o.opt$(EXE)"; \ + cp $(OBJSX) "$(LIBDIR)/camlp4/."; \ + for file in $(OBJSX); do \ + cp "`echo $$file | sed -e 's/\.cmx$$/.$(O)/'`" "$(LIBDIR)/camlp4/."; \ + done ; \ + fi cp mkcamlp4.sh "$(BINDIR)/mkcamlp4" chmod a+x "$(BINDIR)/mkcamlp4" -pa_lisp.cmo: pa_lispr.cmo -pa_scheme.cmo: pa_schemer.cmo -pa_ocamllex.cmo: pa_o.cmo pr_extend.cmo: pa_extfun.cmo pr_o.cmo: pa_extfun.cmo pr_op.cmo: pa_extfun.cmo diff --git a/camlp4/etc/Makefile.Mac b/camlp4/etc/Makefile.Mac deleted file mode 100644 index 7e567cfb..00000000 --- a/camlp4/etc/Makefile.Mac +++ /dev/null @@ -1,71 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: 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 deleted file mode 100644 index c8007dcb..00000000 --- a/camlp4/etc/Makefile.Mac.depend +++ /dev/null @@ -1,40 +0,0 @@ -pa_extfun.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_extfun.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_format.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_format.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_fstream.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_fstream.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_lisp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_lisp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_lispr.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_lispr.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_olabl.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_olabl.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_o.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_o.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_oop.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_oop.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_op.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_op.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_ru.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_ru.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_sml.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_sml.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pr_depend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pr_depend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pr_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_extfun.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_extfun.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_null.cmoÄ ::camlp4:pcaml.cmi -pr_null.cmxÄ ::camlp4:pcaml.cmx -pr_o.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_o.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_op.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_op.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -q_phony.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi -q_phony.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx diff --git a/camlp4/etc/pa_ifdef.ml b/camlp4/etc/pa_ifdef.ml index b43d1ed1..16f4756a 100644 --- a/camlp4/etc/pa_ifdef.ml +++ b/camlp4/etc/pa_ifdef.ml @@ -1,8 +1,12 @@ (* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id: pa_ifdef.ml,v 1.1 2003/07/10 12:28:19 michel Exp $ *) +(* $Id: pa_ifdef.ml,v 1.1.6.1 2004/07/05 09:48:42 mauny Exp $ *) (* This module is deprecated since version 3.07; use pa_macro.ml instead *) +value _ = + prerr_endline "Warning: pa_ifdef is deprecated since OCaml 3.07. Use pa_macro instead." +; + type item_or_def 'a = [ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ] ; @@ -11,7 +15,7 @@ value list_remove x l = List.fold_right (fun e l -> if e = x then l else [e :: l]) l [] ; -value defined = ref ["OCAML_307"; "OCAML_305"; "CAMLP4_300"; "NEWSEQ"]; +value defined = ref ["OCAML_308"; "OCAML_307"; "OCAML_305"; "CAMLP4_300"; "NEWSEQ"]; value define x = defined.val := [x :: defined.val]; value undef x = defined.val := list_remove x defined.val; diff --git a/camlp4/etc/pa_lisp.ml b/camlp4/etc/pa_lisp.ml deleted file mode 100644 index 5dc914f2..00000000 --- a/camlp4/etc/pa_lisp.ml +++ /dev/null @@ -1,684 +0,0 @@ -;; camlp4 ./pa_lispr.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo -;; $Id: 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 deleted file mode 100644 index fb150e20..00000000 --- a/camlp4/etc/pa_lispr.ml +++ /dev/null @@ -1,665 +0,0 @@ -(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) -(* File generated by pretty print; do not edit! *) - -open Pcaml; -open Stdpp; - -type choice 'a 'b = - [ Left of 'a - | Right of 'b ] -; - -(* Buffer *) - -module Buff = - struct - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value get len = String.sub buff.val 0 len; - end -; - -(* Lexer *) - -value rec skip_to_eol = - parser - [ [: `'\n' | '\r' :] -> () - | [: `_; s :] -> skip_to_eol s ] -; - -value no_ident = ['('; ')'; ' '; '\t'; '\n'; '\r'; ';']; - -value rec ident len = - parser - [ [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s - | [: :] -> Buff.get len ] -; - -value rec string len = - parser - [ [: `'"' :] -> Buff.get len - | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s - | [: `x; s :] -> string (Buff.store len x) s ] -; - -value rec number len = - parser - [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s - | [: :] -> ("INT", Buff.get len) ] -; - -value char_or_quote_id x = - parser - [ [: `''' :] -> ("CHAR", String.make 1 x) - | [: s :] -> - let len = Buff.store (Buff.store 0 ''') x in - ("LIDENT", ident len s) ] -; - -value rec char len = - parser - [ [: `''' :] -> len - | [: `x; s :] -> char (Buff.store len x) s ] -; - -value quote = - parser - [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len) - | [: `x; s :] -> char_or_quote_id x s ] -; - -value rec lexer kwt = - parser bp - [ [: `' ' | '\t' | '\n' | '\r'; s :] -> lexer kwt s - | [: `';'; a = semi kwt bp :] -> a - | [: `'(' :] -> (("", "("), (bp, bp + 1)) - | [: `')' :] -> (("", ")"), (bp, bp + 1)) - | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep)) - | [: `'''; tok = quote :] ep -> (tok, (bp, ep)) - | [: `'<'; tok = less :] ep -> (tok, (bp, ep)) - | [: `('0'..'9' as c); n = number (Buff.store 0 c) :] ep -> (n, (bp, ep)) - | [: `x; s = ident (Buff.store 0 x) :] ep -> - let con = - try do { (Hashtbl.find kwt s : unit); "" } with - [ Not_found -> - match x with - [ 'A'..'Z' -> "UIDENT" - | _ -> "LIDENT" ] ] - in - ((con, s), (bp, ep)) - | [: :] -> (("EOI", ""), (bp, bp + 1)) ] -and semi kwt bp = - parser - [ [: `';'; _ = skip_to_eol; s :] -> lexer kwt s - | [: :] ep -> (("", ";"), (bp, ep)) ] -and less = - parser - [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] -> - ("QUOT", lab ^ ":" ^ q) - | [: :] -> ("LIDENT", "<") ] -and label len = - parser - [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s - | [: :] -> Buff.get len ] -and quotation len = - parser - [ [: `'>'; s :] -> quotation_greater len s - | [: `x; s :] -> quotation (Buff.store len x) s - | [: :] -> failwith "quotation not terminated" ] -and quotation_greater len = - parser - [ [: `'>' :] -> Buff.get len - | [: a = quotation (Buff.store len '>') :] -> a ] -; - -value lexer_using kwt (con, prm) = - match con with - [ "CHAR" | "EOI" | "INT" | "LIDENT" | "QUOT" | "STRING" | "UIDENT" -> () - | "ANTIQUOT" -> () - | "" -> - try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ] - | _ -> - raise - (Token.Error - ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ] -; - -value lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " \"" ^ prm ^ "\"" -; - -value lexer_gmake () = - let kwt = Hashtbl.create 89 in - {Token.tok_func = Token.lexer_func_of_parser (lexer kwt); - Token.tok_using = lexer_using kwt; Token.tok_removing = fun []; - Token.tok_match = Token.default_match; Token.tok_text = lexer_text; - Token.tok_comm = None} -; - -(* Building AST *) - -type sexpr = - [ Sexpr of MLast.loc and list sexpr - | Satom of MLast.loc and atom and string - | Squot of MLast.loc and string and string ] -and atom = - [ Alid - | Auid - | Aint - | Achar - | Astring ] -; - -value error_loc loc err = - raise_with_loc loc (Stream.Error (err ^ " expected")) -; -value error se err = - let loc = - match se with [ Satom loc _ _ | Sexpr loc _ | Squot loc _ _ -> loc ] - in - error_loc loc err -; - -value expr_id loc s = - match s.[0] with - [ 'A'..'Z' -> <:expr< $uid:s$ >> - | _ -> <:expr< $lid:s$ >> ] -; - -value patt_id loc s = - match s.[0] with - [ 'A'..'Z' -> <:patt< $uid:s$ >> - | _ -> <:patt< $lid:s$ >> ] -; - -value ctyp_id loc s = - match s.[0] with - [ ''' -> - let s = String.sub s 1 (String.length s - 1) in - <:ctyp< '$s$ >> - | 'A'..'Z' -> <:ctyp< $uid:s$ >> - | _ -> <:ctyp< $lid:s$ >> ] -; - -value strm_n = "strm__"; -value peek_fun loc = <:expr< Stream.peek >>; -value junk_fun loc = <:expr< Stream.junk >>; - -value rec module_expr_se = - fun - [ Sexpr loc [Satom _ Alid "struct" :: sl] -> - let mel = List.map str_item_se sl in - <:module_expr< struct $list:mel$ end >> - | Satom loc Auid s -> <:module_expr< $uid:s$ >> - | se -> error se "module expr" ] -and str_item_se se = - match se with - [ Satom loc _ _ | Squot loc _ _ -> - let e = expr_se se in - <:str_item< $exp:e$ >> - | Sexpr loc [Satom _ Alid "module"; Satom _ Auid i; se] -> - let mb = module_binding_se se in - <:str_item< module $i$ = $mb$ >> - | Sexpr loc [Satom _ Alid "open"; Satom _ Auid s] -> - let s = [s] in - <:str_item< open $s$ >> - | Sexpr loc [Satom _ Alid "type" :: sel] -> - let tdl = type_declaration_list_se sel in - <:str_item< type $list:tdl$ >> - | Sexpr loc [Satom _ Alid "value" :: sel] -> - let (r, sel) = - match sel with - [ [Satom _ Alid "rec" :: sel] -> (True, sel) - | _ -> (False, sel) ] - in - let lbs = value_binding_se sel in - <:str_item< value $opt:r$ $list:lbs$ >> - | Sexpr loc _ -> - let e = expr_se se in - <:str_item< $exp:e$ >> ] -and value_binding_se = - fun - [ [se1; se2 :: sel] -> [(ipatt_se se1, expr_se se2) :: value_binding_se sel] - | [] -> [] - | [se :: _] -> error se "value_binding" ] -and module_binding_se se = module_expr_se se -and expr_se = - fun - [ Satom loc (Alid | Auid) s -> expr_ident_se loc s - | Satom loc Aint s -> <:expr< $int:s$ >> - | Satom loc Achar s -> <:expr< $chr:s$ >> - | Satom loc Astring s -> <:expr< $str:s$ >> - | Sexpr loc [] -> <:expr< () >> - | Sexpr loc [Satom _ Alid "if"; se; se1] -> - let e = expr_se se in - let e1 = expr_se se1 in - <:expr< if $e$ then $e1$ else () >> - | Sexpr loc [Satom _ Alid "if"; se; se1; se2] -> - let e = expr_se se in - let e1 = expr_se se1 in - let e2 = expr_se se2 in - <:expr< if $e$ then $e1$ else $e2$ >> - | Sexpr loc [Satom loc1 Alid "lambda"] -> <:expr< fun [] >> - | Sexpr loc [Satom loc1 Alid "lambda"; sep :: sel] -> - let e = progn_se loc1 sel in - match ipatt_opt_se sep with - [ Left p -> <:expr< fun $p$ -> $e$ >> - | Right (se, sel) -> - List.fold_right - (fun se e -> - let p = ipatt_se se in - <:expr< fun $p$ -> $e$ >>) - [se :: sel] e ] - | Sexpr loc [Satom _ Alid "lambda_match" :: sel] -> - let pel = List.map (match_case loc) sel in - <:expr< fun [ $list:pel$ ] >> - | Sexpr loc [Satom _ Alid "let" :: sel] -> - let (r, sel) = - match sel with - [ [Satom _ Alid "rec" :: sel] -> (True, sel) - | _ -> (False, sel) ] - in - match sel with - [ [Sexpr _ sel1 :: sel2] -> - let lbs = List.map let_binding_se sel1 in - let e = progn_se loc sel2 in - <:expr< let $opt:r$ $list:lbs$ in $e$ >> - | [se :: _] -> error se "let_binding" - | _ -> error_loc loc "let_binding" ] - | Sexpr loc [Satom _ Alid "let*" :: sel] -> - match sel with - [ [Sexpr _ sel1 :: sel2] -> - List.fold_right - (fun se ek -> - let (p, e) = let_binding_se se in - <:expr< let $p$ = $e$ in $ek$ >>) - sel1 (progn_se loc sel2) - | [se :: _] -> error se "let_binding" - | _ -> error_loc loc "let_binding" ] - | Sexpr loc [Satom _ Alid "match"; se :: sel] -> - let e = expr_se se in - let pel = List.map (match_case loc) sel in - <:expr< match $e$ with [ $list:pel$ ] >> - | Sexpr loc [Satom _ Alid "parser" :: sel] -> - let e = - match sel with - [ [(Satom _ _ _ as se) :: sel] -> - let p = patt_se se in - let pc = parser_cases_se loc sel in - <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >> - | _ -> parser_cases_se loc sel ] - in - <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >> - | Sexpr loc [Satom _ Alid "try"; se :: sel] -> - let e = expr_se se in - let pel = List.map (match_case loc) sel in - <:expr< try $e$ with [ $list:pel$ ] >> - | Sexpr loc [Satom _ Alid "progn" :: sel] -> - let el = List.map expr_se sel in - <:expr< do { $list:el$ } >> - | Sexpr loc [Satom _ Alid "while"; se :: sel] -> - let e = expr_se se in - let el = List.map expr_se sel in - <:expr< while $e$ do { $list:el$ } >> - | Sexpr loc [Satom _ Alid ":="; se1; se2] -> - let e2 = expr_se se2 in - match expr_se se1 with - [ <:expr< $uid:"()"$ $e1$ $i$ >> -> <:expr< $e1$.($i$) := $e2$ >> - | e1 -> <:expr< $e1$ := $e2$ >> ] - | Sexpr loc [Satom _ Alid "[]"; se1; se2] -> - let e1 = expr_se se1 in - let e2 = expr_se se2 in - <:expr< $e1$.[$e2$] >> - | Sexpr loc [Satom _ Alid "," :: sel] -> - let el = List.map expr_se sel in - <:expr< ( $list:el$ ) >> - | Sexpr loc [Satom _ Alid "{}" :: sel] -> - let lel = List.map (label_expr_se loc) sel in - <:expr< { $list:lel$ } >> - | Sexpr loc [Satom _ Alid ":"; se1; se2] -> - let e = expr_se se1 in - let t = ctyp_se se2 in - <:expr< ( $e$ : $t$ ) >> - | Sexpr loc [Satom _ Alid "list" :: sel] -> - let rec loop = - fun - [ [] -> <:expr< [] >> - | [se1; Satom _ Alid "::"; se2] -> - let e = expr_se se1 in - let el = expr_se se2 in - <:expr< [$e$ :: $el$] >> - | [se :: sel] -> - let e = expr_se se in - let el = loop sel in - <:expr< [$e$ :: $el$] >> ] - in - loop sel - | Sexpr loc [se :: sel] -> - List.fold_left - (fun e se -> - let e1 = expr_se se in - <:expr< $e$ $e1$ >>) - (expr_se se) sel - | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ] -and progn_se loc = - fun - [ [] -> <:expr< () >> - | [se] -> expr_se se - | sel -> - let el = List.map expr_se sel in - <:expr< do { $list:el$ } >> ] -and let_binding_se = - fun - [ Sexpr loc [se1; se2] -> (ipatt_se se1, expr_se se2) - | se -> error se "let_binding" ] -and match_case loc = - fun - [ Sexpr _ [se1; se2] -> (patt_se se1, None, expr_se se2) - | Sexpr _ [se1; sew; se2] -> (patt_se se1, Some (expr_se sew), expr_se se2) - | se -> error se "match_case" ] -and label_expr_se loc = - fun - [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2) - | se -> error se "label_expr" ] -and expr_ident_se loc s = - if s.[0] = '<' then <:expr< $lid:s$ >> - else - let rec loop ibeg i = - if i = String.length s then - if i > ibeg then expr_id loc (String.sub s ibeg (i - ibeg)) - else - raise_with_loc (fst loc + i - 1, fst loc + i) - (Stream.Error "expr expected") - else if s.[i] = '.' then - if i > ibeg then - let e1 = expr_id loc (String.sub s ibeg (i - ibeg)) in - let e2 = loop (i + 1) (i + 1) in - <:expr< $e1$ . $e2$ >> - else - raise_with_loc (fst loc + i - 1, fst loc + i + 1) - (Stream.Error "expr expected") - else loop ibeg (i + 1) - in - loop 0 0 -and parser_cases_se loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | [Sexpr loc [Sexpr _ spsel :: act] :: sel] -> - let ekont _ = parser_cases_se loc sel in - let act = - match act with - [ [se] -> expr_se se - | [sep; se] -> - let p = patt_se sep in - let e = expr_se se in - <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> error_loc loc "parser_case" ] - in - stream_pattern_se loc act ekont spsel - | [se :: _] -> error se "parser_case" ] -and stream_pattern_se loc act ekont = - fun - [ [] -> act - | [se :: sel] -> - let ckont err = <:expr< raise (Stream.Error $err$) >> in - let skont = stream_pattern_se loc act ckont sel in - stream_pattern_component skont ekont <:expr< "" >> se ] -and stream_pattern_component skont ekont err = - fun - [ Sexpr loc [Satom _ Alid "`"; se :: wol] -> - let wo = - match wol with - [ [se] -> Some (expr_se se) - | [] -> None - | _ -> error_loc loc "stream_pattern_component" ] - in - let e = peek_fun loc in - let p = patt_se se in - let j = junk_fun loc in - let k = ekont err in - <:expr< match $e$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } - | _ -> $k$ ] >> - | Sexpr loc [se1; se2] -> - let p = patt_se se1 in - let e = - let e = expr_se se2 in - <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >> - in - let k = ekont err in - <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >> - | Sexpr loc [Satom _ Alid "?"; se1; se2] -> - stream_pattern_component skont ekont (expr_se se2) se1 - | Satom loc Alid s -> <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >> - | se -> error se "stream_pattern_component" ] -and patt_se = - fun - [ Satom loc Alid "_" -> <:patt< _ >> - | Satom loc (Alid | Auid) s -> patt_ident_se loc s - | Satom loc Aint s -> <:patt< $int:s$ >> - | Satom loc Achar s -> <:patt< $chr:s$ >> - | Satom loc Astring s -> <:patt< $str:s$ >> - | Sexpr loc [Satom _ Alid "or"; se :: sel] -> - List.fold_left - (fun p se -> - let p1 = patt_se se in - <:patt< $p$ | $p1$ >>) - (patt_se se) sel - | Sexpr loc [Satom _ Alid "range"; se1; se2] -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< $p1$ .. $p2$ >> - | Sexpr loc [Satom _ Alid "," :: sel] -> - let pl = List.map patt_se sel in - <:patt< ( $list:pl$ ) >> - | Sexpr loc [Satom _ Alid "as"; se1; se2] -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< ($p1$ as $p2$) >> - | Sexpr loc [Satom _ Alid "list" :: sel] -> - let rec loop = - fun - [ [] -> <:patt< [] >> - | [se1; Satom _ Alid "::"; se2] -> - let p = patt_se se1 in - let pl = patt_se se2 in - <:patt< [$p$ :: $pl$] >> - | [se :: sel] -> - let p = patt_se se in - let pl = loop sel in - <:patt< [$p$ :: $pl$] >> ] - in - loop sel - | Sexpr loc [se :: sel] -> - List.fold_left - (fun p se -> - let p1 = patt_se se in - <:patt< $p$ $p1$ >>) - (patt_se se) sel - | Sexpr loc [] -> <:patt< () >> - | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ] -and patt_ident_se loc s = - loop 0 0 where rec loop ibeg i = - if i = String.length s then - if i > ibeg then patt_id loc (String.sub s ibeg (i - ibeg)) - else - raise_with_loc (fst loc + i - 1, fst loc + i) - (Stream.Error "patt expected") - else if s.[i] = '.' then - if i > ibeg then - let p1 = patt_id loc (String.sub s ibeg (i - ibeg)) in - let p2 = loop (i + 1) (i + 1) in - <:patt< $p1$ . $p2$ >> - else - raise_with_loc (fst loc + i - 1, fst loc + i + 1) - (Stream.Error "patt expected") - else loop ibeg (i + 1) -and ipatt_se se = - match ipatt_opt_se se with - [ Left p -> p - | Right (se, _) -> error se "ipatt" ] -and ipatt_opt_se = - fun - [ Satom loc Alid "_" -> Left <:patt< _ >> - | Satom loc Alid s -> Left <:patt< $lid:s$ >> - | Sexpr loc [Satom _ Alid "," :: sel] -> - let pl = List.map ipatt_se sel in - Left <:patt< ( $list:pl$ ) >> - | Sexpr loc [] -> Left <:patt< () >> - | Sexpr loc [se :: sel] -> Right (se, sel) - | se -> error se "ipatt" ] -and type_declaration_list_se = - fun - [ [se1; se2 :: sel] -> - let (n1, loc1, tpl) = - match se1 with - [ Sexpr _ [Satom loc Alid n :: sel] -> - (n, loc, List.map type_parameter_se sel) - | Satom loc Alid n -> (n, loc, []) - | se -> error se "type declaration" ] - in - [((loc1, n1), tpl, ctyp_se se2, []) :: type_declaration_list_se sel] - | [] -> [] - | [se :: _] -> error se "type_declaration" ] -and type_parameter_se = - fun - [ Satom _ Alid s when String.length s >= 2 && s.[0] = ''' -> - (String.sub s 1 (String.length s - 1), (False, False)) - | se -> error se "type_parameter" ] -and ctyp_se = - fun - [ Sexpr loc [Satom _ Alid "sum" :: sel] -> - let cdl = List.map constructor_declaration_se sel in - <:ctyp< [ $list:cdl$ ] >> - | Sexpr loc [se :: sel] -> - List.fold_left - (fun t se -> - let t2 = ctyp_se se in - <:ctyp< $t$ $t2$ >>) - (ctyp_se se) sel - | Satom loc (Alid | Auid) s -> ctyp_ident_se loc s - | se -> error se "ctyp" ] -and ctyp_ident_se loc s = - loop 0 0 where rec loop ibeg i = - if i = String.length s then - if i > ibeg then ctyp_id loc (String.sub s ibeg (i - ibeg)) - else - raise_with_loc (fst loc + i - 1, fst loc + i) - (Stream.Error "ctyp expected") - else if s.[i] = '.' then - if i > ibeg then - let t1 = ctyp_id loc (String.sub s ibeg (i - ibeg)) in - let t2 = loop (i + 1) (i + 1) in - <:ctyp< $t1$ . $t2$ >> - else - raise_with_loc (fst loc + i - 1, fst loc + i + 1) - (Stream.Error "ctyp expected") - else loop ibeg (i + 1) -and constructor_declaration_se = - fun - [ Sexpr loc [Satom _ Auid ci :: sel] -> (loc, ci, List.map ctyp_se sel) - | se -> error se "constructor_declaration" ] -; - -value top_phrase_se se = - match se with - [ Satom loc _ _ | Squot loc _ _ -> str_item_se se - | Sexpr loc [Satom _ Alid s :: sl] -> - if s.[0] = '#' then - let n = String.sub s 1 (String.length s - 1) in - match sl with - [ [Satom _ Astring s] -> MLast.StDir loc n (Some <:expr< $str:s$ >>) - | _ -> match () with [] ] - else str_item_se se - | Sexpr loc _ -> str_item_se se ] -; - -(* Parser *) - -value phony_quot = ref False; -Pcaml.add_option "-phony_quot" (Arg.Set phony_quot) "phony quotations"; - -Pcaml.no_constructors_arity.val := False; - -do { - Grammar.Unsafe.gram_reinit gram (lexer_gmake ()); - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; - Grammar.Unsafe.clear_entry class_type; - Grammar.Unsafe.clear_entry class_expr; - Grammar.Unsafe.clear_entry class_sig_item; - Grammar.Unsafe.clear_entry class_str_item -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value sexpr = Grammar.Entry.create gram "sexpr"; -value atom = Grammar.Entry.create gram "atom"; - -EXTEND - implem: - [ [ st = LIST0 [ s = str_item -> (s, loc) ]; EOI -> (st, False) ] ] - ; - top_phrase: - [ [ se = sexpr -> Some (top_phrase_se se) - | EOI -> None ] ] - ; - use_file: - [ [ l = LIST0 sexpr; EOI -> (List.map top_phrase_se l, False) ] ] - ; - str_item: - [ [ se = sexpr -> str_item_se se - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - expr: - [ "top" - [ se = sexpr -> expr_se se ] ] - ; - patt: - [ [ se = sexpr -> patt_se se ] ] - ; - sexpr: - [ [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl - | a = atom -> Satom loc Alid a - | s = LIDENT -> Satom loc Alid s - | s = UIDENT -> Satom loc Auid s - | s = INT -> Satom loc Aint s - | s = CHAR -> Satom loc Achar s - | s = STRING -> Satom loc Astring s - | s = QUOT -> - let i = String.index s ':' in - let typ = String.sub s 0 i in - let txt = String.sub s (i + 1) (String.length s - i - 1) in - if phony_quot.val then - Satom loc Alid ("<:" ^ typ ^ "<" ^ txt ^ ">>") - else Squot loc typ txt ] ] - ; - atom: - [ [ "_" -> "_" - | "," -> "," - | "=" -> "=" - | ":" -> ":" - | "." -> "." ] ] - ; -END; diff --git a/camlp4/etc/pa_o.ml b/camlp4/etc/pa_o.ml index 59559132..0b85954b 100644 --- a/camlp4/etc/pa_o.ml +++ b/camlp4/etc/pa_o.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pa_o.ml,v 1.54 2003/09/30 14:39:38 mauny Exp $ *) +(* $Id: pa_o.ml,v 1.58 2004/05/25 11:38:31 mauny Exp $ *) open Stdpp; open Pcaml; @@ -70,6 +70,7 @@ value mkumin loc f arg = <:expr< $lid:f$ $arg$ >> ] ; + value mklistexp loc last = loop True where rec loop top = fun @@ -407,6 +408,7 @@ and sync_semisemi 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; @@ -422,11 +424,13 @@ EXTEND <: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 -> @@ -458,6 +462,7 @@ EXTEND <:str_item< let module $m$ = $mb$ in $e$ >> | e = expr -> <:str_item< $exp:e$ >> ] ] ; + rebind_exn: [ [ "="; sl = mod_ident -> sl | -> [] ] ] @@ -564,7 +569,10 @@ EXTEND "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$ } >> ] + <:expr< while $e1$ do { $list:get_seq e2$ } >> + | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> + (* <:expr< object $opt:cspo$ $list:cf$ end >> *) + MLast.ExObj loc cspo cf ] | [ e = SELF; ","; el = LIST1 NEXT SEP "," -> <:expr< ( $list:[e :: el]$ ) >> ] | ":=" NONA @@ -675,10 +683,13 @@ EXTEND let x = try let i = String.index x ':' in - (int_of_string (String.sub x 0 i), + ({Lexing.pos_fname = ""; + Lexing.pos_lnum = 0; + Lexing.pos_bol = 0; + Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, String.sub x (i + 1) (String.length x - i - 1)) with - [ Not_found | Failure _ -> (0, x) ] + [ Not_found | Failure _ -> (Token.nowhere, x) ] in Pcaml.handle_expr_locate loc x | x = QUOTATION -> @@ -810,10 +821,13 @@ EXTEND let x = try let i = String.index x ':' in - (int_of_string (String.sub x 0 i), + ({Lexing.pos_fname = ""; + Lexing.pos_lnum = 0; + Lexing.pos_bol = 0; + Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, String.sub x (i + 1) (String.length x - i - 1)) with - [ Not_found | Failure _ -> (0, x) ] + [ Not_found | Failure _ -> (Token.nowhere, x) ] in Pcaml.handle_patt_locate loc x | x = QUOTATION -> diff --git a/camlp4/etc/pa_oop.ml b/camlp4/etc/pa_oop.ml index 3780ab52..b8527112 100644 --- a/camlp4/etc/pa_oop.ml +++ b/camlp4/etc/pa_oop.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pa_oop.ml,v 1.3 2002/07/19 14:53:46 mauny Exp $ *) +(* $Id: pa_oop.ml,v 1.4 2004/05/12 15:22:40 mauny Exp $ *) open Pcaml; @@ -109,6 +109,7 @@ value rec cstream gloc = (* Syntax extensions in Ocaml grammar *) + EXTEND GLOBAL: expr; expr: LEVEL "expr1" diff --git a/camlp4/etc/parserify.ml b/camlp4/etc/parserify.ml index 19260cde..00e5c2dd 100644 --- a/camlp4/etc/parserify.ml +++ b/camlp4/etc/parserify.ml @@ -1,7 +1,7 @@ (* camlp4r q_MLast.cmo *) -(* $Id: parserify.ml,v 1.1 2003/07/10 12:28:22 michel Exp $ *) +(* $Id: parserify.ml,v 1.2 2004/05/12 15:22:40 mauny Exp $ *) -value loc = (0, 0); +value loc = (Token.nowhere, Token.nowhere); type spc = [ SPCterm of (MLast.patt * option MLast.expr) diff --git a/camlp4/etc/pr_extend.ml b/camlp4/etc/pr_extend.ml index e19c8a17..ee6c353b 100644 --- a/camlp4/etc/pr_extend.ml +++ b/camlp4/etc/pr_extend.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pr_extend.ml,v 1.12 2002/07/19 14:53:46 mauny Exp $ *) +(* $Id: pr_extend.ml,v 1.13 2004/05/12 15:22:40 mauny Exp $ *) open Pcaml; open Spretty; @@ -99,7 +99,7 @@ value unassoc = value rec unaction = fun - [ <:expr< fun ($lid:locp$ : (int * int)) -> ($a$ : $_$) >> + [ <:expr< fun ($lid:locp$ : (Lexing.position * Lexing.position)) -> ($a$ : $_$) >> when locp = Stdpp.loc_name.val -> let ao = match a with @@ -111,7 +111,7 @@ value rec unaction = 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) + (let loc = (Token.nowhere, Token.nowhere) in [<:patt< _ >> :: pl], a) | _ -> raise Not_found ] ; @@ -174,7 +174,7 @@ and unrule = [ <:expr< ($e1$, Gramext.action $e2$) >> -> let (pl, a) = match unaction e2 with - [ ([], None) -> let loc = (0, 0) in ([], Some <:expr< () >>) + [ ([], None) -> let loc = (Token.nowhere, Token.nowhere) in ([], Some <:expr< () >>) | x -> x ] in let sl = unpsymbol_list (List.rev pl) e1 in @@ -389,6 +389,8 @@ value label = | None -> [: :] ] ; +value intloc loc = ((fst loc).Lexing.pos_cnum, (snd loc).Lexing.pos_cnum); + value assoc = fun [ Some Gramext.NonA -> [: `S LR "NONA" :] @@ -419,7 +421,7 @@ value level_list ll k = value entry (e, pos, ll) k = BEbox - [: `LocInfo (MLast.loc_of_expr e) + [: `LocInfo (intloc(MLast.loc_of_expr e)) (HVbox [: `expr e "" [: `S RO ":" :]; position pos :]); `level_list ll [: :]; `HVbox [: `S RO ";"; k :] :] diff --git a/camlp4/etc/pr_extfun.ml b/camlp4/etc/pr_extfun.ml index 9fafd20e..0e47cdd4 100644 --- a/camlp4/etc/pr_extfun.ml +++ b/camlp4/etc/pr_extfun.ml @@ -1,10 +1,10 @@ (* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(* $Id: pr_extfun.ml,v 1.2 2002/07/19 14:53:46 mauny Exp $ *) +(* $Id: pr_extfun.ml,v 1.3 2004/05/12 15:22:40 mauny Exp $ *) open Pcaml; open Spretty; -value loc = (0, 0); +value loc = (Token.nowhere, Token.nowhere); 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; diff --git a/camlp4/etc/pr_o.ml b/camlp4/etc/pr_o.ml index cc12a24e..c83571fa 100644 --- a/camlp4/etc/pr_o.ml +++ b/camlp4/etc/pr_o.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pr_o.ml,v 1.42 2003/08/25 13:30:13 mauny Exp $ *) +(* $Id: pr_o.ml,v 1.45 2004/05/12 21:33:45 mauny Exp $ *) open Pcaml; open Spretty; @@ -143,7 +143,7 @@ value conv_lab = (* default global loc *) -value loc = (0, 0); +value loc = (Token.nowhere, Token.nowhere); value id_var s = if has_special_chars s || is_infix s then @@ -204,17 +204,19 @@ value private_flag = | _ -> [: :] ] ; +value intloc loc = ((fst loc).Lexing.pos_cnum, (snd loc).Lexing.pos_cnum); + value rec labels loc b vl _ k = match vl with [ [] -> [: b; k :] | [v] -> - [: `label True b v "" k; `LocInfo (snd loc, snd loc) (HVbox [: :]) :] + [: `label True b v "" k; `LocInfo (intloc(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 + [: `LocInfo (intloc loc) (HVbox [: `HVbox [: b; m; `S LR (conv_lab f); `S LR ":" :]; `ctyp t "" [: :] :]); @@ -226,15 +228,15 @@ 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] -> [: `variant b v "" k; `LocInfo (intloc(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 (intloc loc) (HVbox b); `HOVbox [: `S LR c; k :] :] | _ -> HVbox - [: `LocInfo loc (HVbox b); + [: `LocInfo (intloc loc) (HVbox b); `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl "" k :] :] ] ; @@ -342,7 +344,7 @@ value raise_match_failure (bp, ep) k = if Pcaml.input_file.val <> "-" then Stdpp.line_of_loc Pcaml.input_file.val (bp, ep) else - ("-", 1, bp, ep) + ("-", bp.Lexing.pos_lnum, bp.Lexing.pos_cnum - bp.Lexing.pos_bol, ep.Lexing.pos_cnum - ep.Lexing.pos_bol) in HOVbox [: `S LR "raise"; `S LO "("; `S LR "Match_failure"; `S LO "("; @@ -362,7 +364,7 @@ and let_binding b (p, e) _ k = 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)) + LocInfo (intloc loc) (BEbox (let_binding0 b p e k)) and let_binding0 b p e k = let (pl, e) = match p with @@ -387,7 +389,7 @@ and match_assoc_list loc pel dg k = [: `HVbox [: `S LR "_"; `S LR "->" :]; `raise_match_failure loc k :] | _ -> BEVbox - [: `HVbox [: :]; listwbws match_assoc [: :] (S LR "|") pel "" k :] ] + [: `HVbox [: :]; listwbws match_assoc [: :] (S LR "|") pel dg k :] ] and match_assoc b (p, w, e) dg k = let s = match w with @@ -606,7 +608,7 @@ and class_signature cs k = class_self_type [: `S LR "object" :] cst [: `HVbox [: `HVbox [: :]; list class_sig_item csf "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; + `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; `HVbox [: `S LR "end"; k :] :] | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] and class_self_type b cst k = @@ -664,7 +666,7 @@ pr_module_type.pr_levels := [: `S LR "sig"; `HVbox [: `HVbox [: :]; list sig_item s "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; + `LocInfo (intloc(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; @@ -697,7 +699,7 @@ pr_module_expr.pr_levels := [: `HVbox [: :]; `HVbox [: `S LR "struct"; list str_item s "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; + `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; `HVbox [: `S LR "end"; k :] :] | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> fun curr next dg k -> @@ -740,7 +742,7 @@ pr_module_expr.pr_levels := pr_sig_item.pr_levels := [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x); + pr_box s x = LocInfo (intloc(MLast.loc_of_sig_item s)) (HVbox x); pr_rules = extfun Extfun.empty with [ <:sig_item< type $list:stl$ >> -> @@ -788,7 +790,7 @@ pr_sig_item.pr_levels := pr_str_item.pr_levels := [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_str_item s) (HVbox x); + pr_box s x = LocInfo (intloc(MLast.loc_of_str_item s)) (HVbox x); pr_rules = extfun Extfun.empty with [ <:str_item< open $i$ >> -> @@ -871,14 +873,14 @@ value ocaml_char = ; pr_expr.pr_levels := - [{pr_label = "top"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); + [{pr_label = "top"; pr_box e x = LocInfo (intloc(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_label = "expr1"; pr_box e x = LocInfo (intloc(MLast.loc_of_expr e)) (HOVbox x); pr_rules = extfun Extfun.empty with [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> @@ -955,11 +957,11 @@ pr_expr.pr_levels := [: `S LR "fun"; list simple_patt [p :: pl] "" [: `S LR "->" :] :]; - `expr e "" k :] :] + `expr e dg k :] :] | _ -> [: `Vbox [: `HVbox [: :]; `S LR "function"; - `match_assoc_list loc pel "" k :] :] ] + `match_assoc_list loc pel dg k :] :] ] else match pel with [ [] -> @@ -1079,7 +1081,7 @@ pr_expr.pr_levels := `HVbox [: `S LR "else"; `expr1 e dg k :] :] :] ] else match eel_e with - [ (_, <:expr< () >>) -> [: `next e "" k :] + [ (_, <:expr< () >>) -> [: `simple_expr e "" k :] | (eel, e) -> [: `HVbox [: `HVbox [: :]; @@ -1309,7 +1311,7 @@ pr_expr.pr_levels := | 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_box e x = LocInfo (intloc(MLast.loc_of_expr e)) (HOVbox x); pr_rules = extfun Extfun.empty with [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) @@ -1412,7 +1414,7 @@ pr_expr.pr_levels := | 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_label = "top"; pr_box p x = LocInfo (intloc(MLast.loc_of_patt p)) (HOVCbox x); pr_rules = extfun Extfun.empty with [ <:patt< ($x$ as $lid:y$) >> -> @@ -1480,7 +1482,7 @@ pr_patt.pr_levels := | _ -> [: 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_box p x = LocInfo (intloc(MLast.loc_of_patt p)) (HOVbox x); pr_rules = extfun Extfun.empty with [ <:patt< $x$ . $y$ >> -> @@ -1574,7 +1576,7 @@ pr_patt.pr_levels := | 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_label = "top"; pr_box t x = LocInfo (intloc(MLast.loc_of_ctyp t)) (HOVbox x); pr_rules = extfun Extfun.empty with [ <:ctyp< $x$ as $y$ >> -> @@ -1600,7 +1602,7 @@ pr_ctyp.pr_levels := 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_box t x = LocInfo (intloc(MLast.loc_of_ctyp t)) (HOVbox x); pr_rules = extfun Extfun.empty with [ <:ctyp< $t1$ == $t2$ >> -> @@ -1718,7 +1720,7 @@ pr_ctyp.pr_levels := pr_class_str_item.pr_levels := [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x); + pr_box s x = LocInfo (intloc(MLast.loc_of_class_str_item s)) (HVbox x); pr_rules = extfun Extfun.empty with [ MLast.CrDcl _ s -> @@ -1756,7 +1758,7 @@ pr_class_str_item.pr_levels := pr_class_sig_item.pr_levels := [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x); + pr_box s x = LocInfo (intloc(MLast.loc_of_class_sig_item s)) (HVbox x); pr_rules = extfun Extfun.empty with [ MLast.CgCtr _ t1 t2 -> @@ -1834,7 +1836,7 @@ pr_class_expr.pr_levels := [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; `HVbox [: `HVbox [: :]; list class_str_item cf "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; + `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; `HVbox [: `S LR "end"; k :] :] :] | MLast.CeTyc _ ce ct -> fun curr next dg k -> @@ -2006,16 +2008,16 @@ value apply_printer printer ast = List.fold_left (fun (first, last_pos) (si, (bp, ep)) -> do { - copy_source ic oc first last_pos bp; + copy_source ic oc first last_pos.Lexing.pos_cnum bp.Lexing.pos_cnum; flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp + print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp.Lexing.pos_cnum (printer si "" [: :]); flush oc; (False, ep) }) - (True, 0) ast + (True, Token.nowhere) ast in - do { copy_to_end ic oc first last_pos; flush oc } + do { copy_to_end ic oc first last_pos.Lexing.pos_cnum; flush oc } with x -> do { close_in ic; cleanup (); raise x }; close_in ic; diff --git a/camlp4/etc/pr_op_main.ml b/camlp4/etc/pr_op_main.ml index 356aeee1..d81ec732 100644 --- a/camlp4/etc/pr_op_main.ml +++ b/camlp4/etc/pr_op_main.ml @@ -10,12 +10,12 @@ (* *) (***********************************************************************) -(* $Id: pr_op_main.ml,v 1.1 2003/07/10 12:28:22 michel Exp $ *) +(* $Id: pr_op_main.ml,v 1.2 2004/05/12 15:22:40 mauny Exp $ *) open Pcaml; open Spretty; -value loc = (0, 0); +value loc = (Token.nowhere, Token.nowhere); 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; diff --git a/camlp4/etc/pr_r.ml b/camlp4/etc/pr_r.ml index 8df612c9..c1714559 100644 --- a/camlp4/etc/pr_r.ml +++ b/camlp4/etc/pr_r.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pr_r.ml,v 1.46 2003/07/16 12:50:08 mauny Exp $ *) +(* $Id: pr_r.ml,v 1.48 2004/05/12 15:22:41 mauny Exp $ *) open Pcaml; open Spretty; @@ -28,7 +28,7 @@ value gen_where = ref True; value old_sequences = ref False; value expand_declare = ref False; -external is_printable : char -> bool = "is_printable"; +external is_printable : char -> bool = "caml_is_printable"; value char_escaped = fun @@ -127,7 +127,7 @@ value flag n f = if f then [: `S LR n :] else [: :]; (* default global loc *) -value loc = (0, 0); +value loc = (Token.nowhere, Token.nowhere); (* extensible printers *) @@ -150,6 +150,8 @@ 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; +value intloc loc = ((fst loc).Lexing.pos_cnum, (snd loc).Lexing.pos_cnum); + (* type core *) value rec labels loc b vl k = @@ -158,13 +160,13 @@ value rec labels loc b vl k = | [v] -> [: `HVbox [: `HVbox [: :]; `label True b v [: :]; - `LocInfo (snd loc, snd loc) (HVbox k) :] :] + `LocInfo (intloc(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 + [: `LocInfo (intloc loc) (HVbox [: `HVbox [: b; `S LR f; `S LR ":" :]; `HVbox [: m; `ctyp t [: :] :] :]); @@ -179,14 +181,14 @@ value rec variants loc b vl k = | [v] -> [: `HVbox [: `HVbox [: :]; `variant b v [: :]; - `LocInfo (snd loc, snd loc) (HVbox k) :] :] + `LocInfo (intloc(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 (intloc loc) (HVbox b); `HOVbox [: `S LR c; k :] :] | _ -> HVbox - [: `LocInfo loc (HVbox b); + [: `LocInfo (intloc loc) (HVbox b); `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl k :] :] ] ; @@ -321,7 +323,7 @@ and let_binding b (p, e) k = 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 :]) + LocInfo (intloc 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 @@ -603,7 +605,7 @@ and class_signature cs k = class_self_type [: `S LR "object" :] cst [: `HVbox [: `HVbox [: :]; list class_sig_item csf [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; + `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; `HVbox [: `S LR "end"; k :] :] | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] and class_self_type b cst k = @@ -658,7 +660,7 @@ pr_module_type.pr_levels := [: `S LR "sig"; `HVbox [: `HVbox [: :]; list sig_item s [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; + `LocInfo (intloc(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; @@ -695,7 +697,7 @@ pr_module_expr.pr_levels := [: `HVbox [: :]; `HVbox [: `S LR "struct"; list str_item s [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; + `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; `HVbox [: `S LR "end"; k :] :] | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> fun curr next _ k -> @@ -735,7 +737,7 @@ pr_module_expr.pr_levels := pr_sig_item.pr_levels := [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x); + pr_box s x = LocInfo (intloc(MLast.loc_of_sig_item s)) (HVbox x); pr_rules = extfun Extfun.empty with [ <:sig_item< type $list:stl$ >> -> @@ -788,7 +790,7 @@ pr_sig_item.pr_levels := pr_str_item.pr_levels := [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_str_item s) (HVbox x); + pr_box s x = LocInfo (intloc(MLast.loc_of_str_item s)) (HVbox x); pr_rules = extfun Extfun.empty with [ <:str_item< open $i$ >> -> @@ -885,7 +887,7 @@ END; *) pr_expr.pr_levels := - [{pr_label = "top"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); + [{pr_label = "top"; pr_box e x = LocInfo (intloc(MLast.loc_of_expr e)) (HOVbox x); pr_rules = extfun Extfun.empty with [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> @@ -1163,7 +1165,7 @@ pr_expr.pr_levels := 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_box e x = LocInfo (intloc(MLast.loc_of_expr e)) (HOVbox x); pr_rules = extfun Extfun.empty with [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) -> @@ -1274,7 +1276,7 @@ pr_expr.pr_levels := pr_patt.pr_levels := [{pr_label = "top"; - pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox [: `HVbox [: :]; x :]); + pr_box p x = LocInfo (intloc(MLast.loc_of_patt p)) (HOVbox [: `HVbox [: :]; x :]); pr_rules = extfun Extfun.empty with [ <:patt< $x$ | $y$ >> -> @@ -1301,7 +1303,7 @@ pr_patt.pr_levels := 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_box p x = LocInfo (intloc(MLast.loc_of_patt p)) (HOVbox x); pr_rules = extfun Extfun.empty with [ <:patt< [$_$ :: $_$] >> as p -> @@ -1408,7 +1410,7 @@ pr_patt.pr_levels := | 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_label = "top"; pr_box t x = LocInfo (intloc(MLast.loc_of_ctyp t)) (HOVbox x); pr_rules = extfun Extfun.empty with [ <:ctyp< $t1$ == $t2$ >> -> @@ -1460,7 +1462,7 @@ pr_ctyp.pr_levels := [: 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_box t x = LocInfo (intloc(MLast.loc_of_ctyp t)) (HOVbox x); pr_rules = extfun Extfun.empty with [ <:ctyp< ($list:tl$) >> -> @@ -1536,7 +1538,7 @@ pr_ctyp.pr_levels := pr_class_sig_item.pr_levels := [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x); + pr_box s x = LocInfo (intloc(MLast.loc_of_class_sig_item s)) (HVbox x); pr_rules = extfun Extfun.empty with [ <:class_sig_item< type $t1$ = $t2$ >> -> @@ -1579,7 +1581,7 @@ pr_class_sig_item.pr_levels := pr_class_str_item.pr_levels := [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x); + pr_box s x = LocInfo (intloc(MLast.loc_of_class_str_item s)) (HVbox x); pr_rules = extfun Extfun.empty with [ MLast.CrDcl _ s -> @@ -1664,7 +1666,7 @@ pr_class_expr.pr_levels := [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; `HVbox [: `HVbox [: :]; list class_str_item cf [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; + `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; `HVbox [: `S LR "end"; k :] :] :] | MLast.CeTyc _ ce ct -> fun curr next _ k -> @@ -1838,16 +1840,16 @@ value apply_printer printer ast = List.fold_left (fun (first, last_pos) (si, (bp, ep)) -> do { - copy_source ic oc first last_pos bp; + copy_source ic oc first last_pos.Lexing.pos_cnum bp.Lexing.pos_cnum; flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp + print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp.Lexing.pos_cnum (printer si [: :]); flush oc; (False, ep) }) - (True, 0) ast + (True, Token.nowhere) ast in - do { copy_to_end ic oc first last_pos; flush oc } + do { copy_to_end ic oc first last_pos.Lexing.pos_cnum; flush oc } with x -> do { close_in ic; cleanup (); raise x }; close_in ic; diff --git a/camlp4/etc/pr_rp.ml b/camlp4/etc/pr_rp.ml index 02daa6af..2ce626e0 100644 --- a/camlp4/etc/pr_rp.ml +++ b/camlp4/etc/pr_rp.ml @@ -10,12 +10,12 @@ (* *) (***********************************************************************) -(* $Id: pr_rp.ml,v 1.4 2002/07/19 14:53:47 mauny Exp $ *) +(* $Id: pr_rp.ml,v 1.5 2004/05/12 15:22:41 mauny Exp $ *) open Pcaml; open Spretty; -value loc = (0, 0); +value loc = (Token.nowhere, Token.nowhere); 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; diff --git a/camlp4/etc/pr_rp_main.ml b/camlp4/etc/pr_rp_main.ml index 38d25864..81b39678 100644 --- a/camlp4/etc/pr_rp_main.ml +++ b/camlp4/etc/pr_rp_main.ml @@ -10,12 +10,12 @@ (* *) (***********************************************************************) -(* $Id: pr_rp_main.ml,v 1.1 2003/07/10 12:28:23 michel Exp $ *) +(* $Id: pr_rp_main.ml,v 1.2 2004/05/12 15:22:41 mauny Exp $ *) open Pcaml; open Spretty; -value loc = (0, 0); +value loc = (Token.nowhere, Token.nowhere); 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; diff --git a/camlp4/etc/q_phony.ml b/camlp4/etc/q_phony.ml index 2481c7fc..ae5a143a 100644 --- a/camlp4/etc/q_phony.ml +++ b/camlp4/etc/q_phony.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: q_phony.ml,v 1.3 2003/07/10 12:28:24 michel Exp $ *) +(* $Id: q_phony.ml,v 1.4 2004/05/12 15:22:41 mauny Exp $ *) open Pcaml; @@ -23,14 +23,14 @@ Quotation.add "" if t.val = "" then "<<" ^ s ^ ">>" else "<:" ^ t.val ^ "<" ^ s ^ ">>" in - let loc = (0, 0) in + let loc = (Token.nowhere, Token.nowhere) in <:expr< $uid:t$ >>, fun s -> let t = if t.val = "" then "<<" ^ s ^ ">>" else "<:" ^ t.val ^ "<" ^ s ^ ">>" in - let loc = (0, 0) in + let loc = (Token.nowhere, Token.nowhere) in <:patt< $uid:t$ >>)) ; diff --git a/camlp4/lib/.depend b/camlp4/lib/.depend index 0d5adc69..d7afaebe 100644 --- a/camlp4/lib/.depend +++ b/camlp4/lib/.depend @@ -2,6 +2,7 @@ extfold.cmi: gramext.cmi gramext.cmi: token.cmi grammar.cmi: gramext.cmi token.cmi plexer.cmi: token.cmi +stdpp.cmi: token.cmi extfold.cmo: gramext.cmi grammar.cmi extfold.cmi extfold.cmx: gramext.cmx grammar.cmx extfold.cmi extfun.cmo: extfun.cmi @@ -14,7 +15,7 @@ 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 +stdpp.cmo: token.cmi stdpp.cmi +stdpp.cmx: token.cmx stdpp.cmi token.cmo: token.cmi token.cmx: token.cmi diff --git a/camlp4/lib/Makefile b/camlp4/lib/Makefile index 781339fb..5e26f419 100644 --- a/camlp4/lib/Makefile +++ b/camlp4/lib/Makefile @@ -1,4 +1,4 @@ -# $Id: Makefile,v 1.7 2003/08/29 12:15:15 xleroy Exp $ +# $Id: Makefile,v 1.8.2.4 2004/07/09 15:09:46 doligez Exp $ include ../config/Makefile @@ -9,7 +9,10 @@ SHELL=/bin/sh TARGET=gramlib.cma all: $(TARGET) -opt: $(TARGET:.cma=.cmxa) +opt: opt$(PROFILING) + +optnoprof: $(TARGET:.cma=.cmxa) +optprof: optnoprof $(TARGET:.cma=.p.cmxa) $(TARGET): $(OBJS) $(OCAMLC) $(OBJS) -a -o $(TARGET) @@ -17,6 +20,9 @@ $(TARGET): $(OBJS) $(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx) $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa) +$(TARGET:.cma=.p.cmxa): $(OBJS:.cmo=.p.cmx) + $(OCAMLOPT) $(OBJS:.cmo=.p.cmx) -a -o $(TARGET:.cma=.p.cmxa) + clean:: rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET) @@ -39,10 +45,14 @@ install: -$(MKDIR) "$(LIBDIR)/camlp4" cp $(TARGET) *.mli "$(LIBDIR)/camlp4/." cp *.cmi "$(LIBDIR)/camlp4/." - if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi + test -f $(TARGET:.cma=.cmxa) && $(MAKE) installopt LIBDIR="$(LIBDIR)" || true installopt: - cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/." - tar cf - $(TARGET:.cma=.$(A)) | (cd "$(LIBDIR)/camlp4/."; tar xf -) + for f in $(TARGET:.cma=.cmxa) $(TARGET:.cma=.p.cmxa) ; do \ + test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true ; \ + done + # Special treatment for this one: some versions of make don't like $(A) in $(TARGET:.cma=.$(A)) + target="`echo $(TARGET) | sed -e 's/\.cma$$/.$(A)/'`" ; \ + test -f $$target && cp $$target "$(LIBDIR)/camlp4/." || true include .depend diff --git a/camlp4/lib/Makefile.Mac b/camlp4/lib/Makefile.Mac deleted file mode 100644 index 1b27c216..00000000 --- a/camlp4/lib/Makefile.Mac +++ /dev/null @@ -1,46 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: 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 deleted file mode 100644 index 8d12e3e0..00000000 --- a/camlp4/lib/Makefile.Mac.depend +++ /dev/null @@ -1,13 +0,0 @@ -gramext.cmoÄ token.cmi gramext.cmi -gramext.cmxÄ token.cmx gramext.cmi -gramext.cmiÄ token.cmi -grammar.cmoÄ gramext.cmi stdpp.cmi token.cmi grammar.cmi -grammar.cmxÄ gramext.cmx stdpp.cmx token.cmx grammar.cmi -grammar.cmiÄ gramext.cmi token.cmi -plexer.cmoÄ stdpp.cmi token.cmi plexer.cmi -plexer.cmxÄ stdpp.cmx token.cmx plexer.cmi -plexer.cmiÄ token.cmi -stdpp.cmoÄ stdpp.cmi -stdpp.cmxÄ stdpp.cmi -token.cmoÄ token.cmi -token.cmxÄ token.cmi diff --git a/camlp4/lib/grammar.ml b/camlp4/lib/grammar.ml index dc88dbce..21ee8899 100644 --- a/camlp4/lib/grammar.ml +++ b/camlp4/lib/grammar.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: grammar.ml,v 1.11 2003/07/10 12:28:25 michel Exp $ *) +(* $Id: grammar.ml,v 1.12 2004/05/12 15:22:42 mauny Exp $ *) open Stdpp; open Gramext; @@ -203,14 +203,14 @@ 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) + if bp == 0 then (Token.nowhere, Token.succ_pos Token.nowhere) else let a = snd (floc.val (bp - 1)) in - (a, a + 1) + (a, Token.succ_pos a) 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) + (if Token.lt_pos bp1 ep1 then bp1 else ep1, if Token.lt_pos ep2 bp2 then bp2 else ep2) ; value rec name_of_symbol entry = @@ -737,8 +737,7 @@ value parse_parsable entry efun (cs, (ts, fun_loc)) = 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) + with _ -> (Token.nowhere, Token.succ_pos Token.nowhere) in do { floc.val := fun_loc; @@ -758,7 +757,7 @@ value parse_parsable entry efun (cs, (ts, fun_loc)) = let loc = get_loc () in do { restore (); raise_with_loc loc exc } | exc -> - let loc = (Stream.count cs, Stream.count cs + 1) in + let loc = (Token.nowhere, Token.succ_pos Token.nowhere) in do { restore (); raise_with_loc loc exc } ] } ; @@ -1009,7 +1008,7 @@ 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)); + type parsable = (Stream.t char * (Stream.t te * Token.flocation_function)); value gram = gcreate L.lexer; value parsable cs = (cs, L.lexer.Token.tok_func cs); value tokens = tokens gram; diff --git a/camlp4/lib/grammar.mli b/camlp4/lib/grammar.mli index b363d333..5fc21b23 100644 --- a/camlp4/lib/grammar.mli +++ b/camlp4/lib/grammar.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: grammar.mli,v 1.5 2003/07/10 12:28:25 michel Exp $ *) +(* $Id: grammar.mli,v 1.6 2004/05/12 15:22:42 mauny Exp $ *) (** Extensible grammars. @@ -192,7 +192,7 @@ value create : Token.lexer -> g; (*** For system use *) -value loc_of_token_interval : int -> int -> (int * int); +value loc_of_token_interval : int -> int -> Token.flocation; value extend : list (Gramext.g_entry 'te * option Gramext.position * diff --git a/camlp4/lib/plexer.ml b/camlp4/lib/plexer.ml index be680c83..a1cd5231 100644 --- a/camlp4/lib/plexer.ml +++ b/camlp4/lib/plexer.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: plexer.ml,v 1.16 2003/09/25 12:05:06 mauny Exp $ *) +(* $Id: plexer.ml,v 1.20.2.1 2004/06/30 13:05:31 mauny Exp $ *) open Stdpp; open Token; @@ -88,6 +88,9 @@ and digits_under kind len = parser [ [: d = kind; s :] -> digits_under kind (store len d) s | [: `'_'; s :] -> digits_under kind len s + | [: `'l' :] -> ("INT32", get_buff len) + | [: `'L' :] -> ("INT64", get_buff len) + | [: `'n' :] -> ("NATIVEINT", get_buff len) | [: :] -> ("INT", get_buff len) ] and octal = parser [ [: `('0'..'7' as d) :] -> d ] and hexa = parser [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d) :] -> d ] @@ -126,388 +129,102 @@ and end_exponent_part_under 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 ] +(* Debugging positions and locations *) +value eprint_pos msg p = + Printf.eprintf "%s: fname=%s; lnum=%d; bol=%d; cnum=%d\n%!" + msg p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum ; -*) -value next_token_fun dfa ssd find_kwd bolpos glexr = - let keyword_or_error loc s = - try (("", find_kwd s), loc) with - [ Not_found -> +value eprint_loc (bp, ep) = + do { eprint_pos "P1" bp; eprint_pos "P2" ep } +; + +value check_location msg ((bp, ep) as loc) = + let ok = + if (bp.Lexing.pos_lnum > ep.Lexing.pos_lnum || + bp.Lexing.pos_bol > ep.Lexing.pos_bol || + bp.Lexing.pos_cnum > ep.Lexing.pos_cnum || + bp.Lexing.pos_lnum < 0 || ep.Lexing.pos_lnum < 0 || + bp.Lexing.pos_bol < 0 || ep.Lexing.pos_bol < 0 || + bp.Lexing.pos_cnum < 0 || ep.Lexing.pos_cnum < 0) + (* Here, we don't check + bp.Lexing.pos_cnum < bp.Lexing.pos_bol || ep.Lexing.pos_cnum < bp.Lexing.pos_bol + since the lexer is called on antiquotations, with cnum=0, but lnum and bolpos + have "correct" values *) + then + do { + Printf.eprintf "*** Warning: (%s) strange positions ***\n" msg; + eprint_loc loc; + False + } + else + True in + (ok, loc) +; + +value next_token_fun dfa ssd find_kwd fname lnum bolpos glexr = + let make_pos p = + {Lexing.pos_fname = fname.val; Lexing.pos_lnum = lnum.val; + Lexing.pos_bol = bolpos.val; Lexing.pos_cnum = p} in + let mkloc (bp, ep) = (make_pos bp, make_pos ep) in + let keyword_or_error (bp,ep) s = + let loc = mkloc (bp, ep) in + try (("", find_kwd s), loc) with + [ Not_found -> if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s) else (("", s), loc) ] in - let error_if_keyword ( ((_,id), loc) as a) = + let error_if_keyword ( ((_,id) as a), bep) = + let loc = mkloc bep in try do { ignore(find_kwd id); err loc ("illegal use of a keyword as a label: " ^ id) } - with [ Not_found -> a ] + with [ Not_found -> (a, loc) ] in let rec next_token after_space = parser bp - [ [: `'\010' | '\013'; s :] ep -> - do { bolpos.val := ep; next_token True s } + [ [: `'\010'; s :] ep -> + do { bolpos.val := ep; incr lnum; next_token True s } + | [: `'\013'; s :] ep -> + let ep = + match Stream.peek s with + [ Some '\010' -> do { Stream.junk s; ep+1 } + | _ -> ep ] in + do { bolpos.val := ep; incr lnum; 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 } + if linedir 1 s then do { line_directive 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 + let loc = mkloc (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 + let loc = mkloc (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 + let loc = mkloc (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 + let loc = mkloc (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 + let loc = mkloc (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 + let loc = mkloc (bp, Stream.count s) in (tok, loc) | [: `'$'; s :] -> let tok = dollar bp 0 s in - let loc = (bp, Stream.count s) in + let loc = mkloc (bp, Stream.count s) in (tok, loc) | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c); s :] -> @@ -519,7 +236,7 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep -> let id = get_buff len in match s with parser - [ [: `':' :] eb -> error_if_keyword (("LABEL", id), (bp,ep)) + [ [: `':' :] eb -> error_if_keyword (("LABEL", id), (bp, ep)) | [: :] -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) ] | [: s :] -> let id = get_buff (ident2 (store 0 c) s) in @@ -577,9 +294,9 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = [ [: `';' :] -> ";;" | [: :] -> ";" ] :] ep -> keyword_or_error (bp, ep) id - | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep)) + | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), mkloc (bp, ep)) | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) - | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] + | [: _ = Stream.empty :] -> (("EOI", ""), mkloc (bp, succ bp)) ] and less bp strm = if no_quotations.val then match strm with parser @@ -589,25 +306,39 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = else match strm with parser [ [: `'<'; len = quotation bp 0 :] ep -> - (("QUOTATION", ":" ^ get_buff len), (bp, ep)) + (("QUOTATION", ":" ^ get_buff len), mkloc (bp, ep)) | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; `'<' ? "character '<' expected"; len = quotation bp 0 :] ep -> - (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)) + (("QUOTATION", i ^ ":" ^ get_buff len), mkloc (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 :] ep -> string bp (store (store len '\\') c) s + | [: `'\010'; s :] ep -> do { bolpos.val := ep; incr lnum; string bp len s } + | [: `'\013'; s :] ep -> + let (len, ep) = + match Stream.peek s with + [ Some '\010' -> do { Stream.junk s; (store (store len '\013') '\010', ep+1) } + | _ -> (store len '\013', ep) ] in + do { bolpos.val := ep; incr lnum; string bp len s } | [: `c; s :] -> string bp (store len c) s - | [: :] ep -> err (bp, ep) "string not terminated" ] + | [: :] ep -> err (mkloc (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 + | [: `'\010'; s :] -> do {bolpos.val := bp+1; incr lnum; char bp (store len '\010') s} + | [: `'\013'; s :] -> + let bol = + match Stream.peek s with + [ Some '\010' -> do { Stream.junk s; bp+2 } + | _ -> bp+1 ] in + do { bolpos.val := bol; incr lnum; char bp (store len '\013') s} | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err (bp, ep) "char not terminated" ] + | [: :] ep -> err (mkloc (bp, ep)) "char not terminated" ] and dollar bp len = parser [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) @@ -623,7 +354,7 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = match s with parser [ [: `c :] -> ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] + | [: :] ep -> err (mkloc (bp, ep)) "antiquotation not terminated" ] else ("", get_buff (ident2 (store 0 '$') s)) ] and maybe_locate bp len = parser @@ -635,7 +366,7 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = ("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" ] + | [: :] ep -> err (mkloc (bp, ep)) "antiquotation not terminated" ] and antiquot bp len = parser [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) @@ -648,13 +379,13 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = ("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" ] + | [: :] ep -> err (mkloc (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" ] + | [: :] ep -> err (mkloc (bp, ep)) "antiquotation not terminated" ] and quotation bp len = parser [ [: `'>'; s :] -> maybe_end_quotation bp len s @@ -667,8 +398,15 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = | [: :] -> store len '\\' ]; s :] -> quotation bp len s + | [: `'\010'; s :] -> do {bolpos.val := bp+1; incr lnum; quotation bp (store len '\010') s} + | [: `'\013'; s :] -> + let bol = + match Stream.peek s with + [ Some '\010' -> do { Stream.junk s; bp+2 } + | _ -> bp+1 ] in + do { bolpos.val := bol; incr lnum; quotation bp (store len '\013') s} | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err (bp, ep) "quotation not terminated" ] + | [: :] ep -> err (mkloc (bp, ep)) "quotation not terminated" ] and maybe_nested_quotation bp len = parser [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" @@ -693,8 +431,15 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = | [: `'*'; 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" ] + | [: `'\010'; s :] ep -> do { bolpos.val := ep; incr lnum; comment bp s } + | [: `'\013'; s :] ep -> + let ep = + match Stream.peek s with + [ Some '\010' -> do { Stream.junk s; ep+1 } + | _ -> ep ] in + do { bolpos.val := ep; incr lnum; comment bp s } + | [: `c; s :] -> comment bp s + | [: :] ep -> err (mkloc (bp, ep)) "comment not terminated" ] and quote_in_comment bp = parser [ [: `'''; s :] -> comment bp s @@ -702,7 +447,15 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = | [: s :] -> do { match Stream.npeek 2 s with - [ [_; '''] -> do { Stream.junk s; Stream.junk s } + [ [ ( '\013' | '\010' ); '''] -> + do { bolpos.val := bp + 1; incr lnum; + Stream.junk s; Stream.junk s } + | [ '\013'; '\010' ] -> + match Stream.npeek 3 s with + [ [_; _; '''] -> do { bolpos.val := bp + 2; incr lnum; + Stream.junk s; Stream.junk s; Stream.junk s } + | _ -> () ] + | [_; '''] -> do { Stream.junk s; Stream.junk s } | _ -> () ]; comment bp s } ] @@ -736,22 +489,42 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = 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 + | Some ('0'..'9') -> True | _ -> False ] and any_to_nl = parser - [ [: `'\013' | '\010' :] ep -> bolpos.val := ep + [ [: `'\010'; s :] ep -> + do { bolpos.val := ep; incr lnum } + | [: `'\013'; s :] ep -> + let ep = + match Stream.peek s with + [ Some '\010' -> do { Stream.junk s; ep+1 } + | _ -> ep ] in + do { bolpos.val := ep; incr lnum } | [: `_; s :] -> any_to_nl s | [: :] -> () ] + and line_directive = parser (* we are sure that there is a line directive here *) + [ [: _ = skip_spaces; n = line_directive_number 0; + _ = skip_spaces; _ = line_directive_string; + _ = any_to_nl :] ep + -> do { bolpos.val := ep; lnum.val := n } + ] + and skip_spaces = parser + [ [: `' ' | '\t'; s :] -> skip_spaces s + | [: :] -> () ] + and line_directive_number n = parser + [ [: `('0'..'9' as c) ; s :] + -> line_directive_number (10*n + (Char.code c - Char.code '0')) s + | [: :] -> n ] + and line_directive_string = parser + [ [: ` '"' ; _ = line_directive_string_contents 0 :] -> () + | [: :] -> () + ] + and line_directive_string_contents len = parser + [ [: ` '\010' | '\013' :] -> () + | [: ` '"' :] -> fname.val := get_buff len + | [: `c; s :] -> line_directive_string_contents (store len c) s + ] in fun cstrm -> try @@ -761,8 +534,9 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = do { match glex.tok_comm with [ Some list -> - if fst (snd r) > comm_bp then - let comm_loc = (comm_bp, fst (snd r)) in + let next_bp = (fst (snd r)).Lexing.pos_cnum in + if next_bp > comm_bp then + let comm_loc = mkloc (comm_bp, next_bp) in glex.tok_comm := Some [comm_loc :: list] else () | None -> () ]; @@ -770,7 +544,7 @@ value next_token_fun dfa ssd find_kwd bolpos glexr = } with [ Stream.Error str -> - err (Stream.count cstrm, Stream.count cstrm + 1) str ] + err (mkloc (Stream.count cstrm, Stream.count cstrm + 1)) str ] ; @@ -779,10 +553,12 @@ value specific_space_dot = ref False; value func kwd_table glexr = let bolpos = ref 0 in + let lnum = ref 1 in + let fname = ref "" 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) + Token.lexer_func_of_parser (next_token_fun dfa ssd find fname lnum bolpos glexr) ; value rec check_keyword_stream = diff --git a/camlp4/lib/stdpp.ml b/camlp4/lib/stdpp.ml index c8d7c6a3..cbd9bcb2 100644 --- a/camlp4/lib/stdpp.ml +++ b/camlp4/lib/stdpp.ml @@ -10,9 +10,9 @@ (* *) (***********************************************************************) -(* $Id: stdpp.ml,v 1.4 2003/07/10 12:28:25 michel Exp $ *) +(* $Id: stdpp.ml,v 1.5 2004/05/12 15:22:42 mauny Exp $ *) -exception Exc_located of (int * int) and exn; +exception Exc_located of Token.flocation and exn; value raise_with_loc loc exc = match exc with @@ -20,6 +20,14 @@ value raise_with_loc loc exc = | _ -> raise (Exc_located loc exc) ] ; +value line_of_loc fname (bp, ep) = + (bp.Lexing.pos_fname, + bp.Lexing.pos_lnum, + bp.Lexing.pos_cnum - bp.Lexing.pos_bol, + ep.Lexing.pos_cnum - bp.Lexing.pos_bol) +; + +(* value line_of_loc fname (bp, ep) = try let ic = open_in_bin fname in @@ -75,5 +83,6 @@ value line_of_loc fname (bp, ep) = with [ Sys_error _ -> (fname, 1, bp, ep) ] ; +*) value loc_name = ref "loc"; diff --git a/camlp4/lib/stdpp.mli b/camlp4/lib/stdpp.mli index 1a4490b8..d053a6a6 100644 --- a/camlp4/lib/stdpp.mli +++ b/camlp4/lib/stdpp.mli @@ -10,22 +10,22 @@ (* *) (***********************************************************************) -(* $Id: stdpp.mli,v 1.4 2003/07/10 12:28:25 michel Exp $ *) +(* $Id: stdpp.mli,v 1.5 2004/05/12 15:22:42 mauny Exp $ *) (** Standard definitions. *) -exception Exc_located of (int * int) and exn; +exception Exc_located of Token.flocation 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; +value raise_with_loc : Token.flocation -> 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); +value line_of_loc : string -> Token.flocation -> (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 diff --git a/camlp4/lib/token.ml b/camlp4/lib/token.ml index ecb56d86..719f751c 100644 --- a/camlp4/lib/token.ml +++ b/camlp4/lib/token.ml @@ -10,16 +10,30 @@ (* *) (***********************************************************************) -(* $Id: token.ml,v 1.8 2003/07/10 12:28:25 michel Exp $ *) +(* $Id: token.ml,v 1.11.2.1 2004/06/28 18:30:48 mauny 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); +value make_loc (bp, ep) = + ({ (Lexing.dummy_pos) with Lexing.pos_cnum = bp; Lexing.pos_lnum = 1 }, + { (Lexing.dummy_pos) with Lexing.pos_cnum = ep; Lexing.pos_lnum = 1 }) +; + +value nowhere = { (Lexing.dummy_pos) with Lexing.pos_cnum = 0 }; + +value dummy_loc = (Lexing.dummy_pos, Lexing.dummy_pos); + +value succ_pos p = + { ( p ) with Lexing.pos_cnum = p.Lexing.pos_cnum + 1}; +value lt_pos p1 p2 = p1.Lexing.pos_cnum < p2.Lexing.pos_cnum; + +type flocation = (Lexing.position * Lexing.position); + +type flocation_function = int -> flocation; +type lexer_func 'te = Stream.t char -> (Stream.t 'te * flocation_function); type glexer 'te = { tok_func : lexer_func 'te; @@ -27,7 +41,7 @@ type glexer 'te = tok_removing : pattern -> unit; tok_match : pattern -> 'te -> string; tok_text : pattern -> string; - tok_comm : mutable option (list location) } + tok_comm : mutable option (list flocation) } ; type lexer = { func : lexer_func t; @@ -43,31 +57,41 @@ value lexer_text (con, prm) = else con ^ " '" ^ prm ^ "'" ; -value locerr () = invalid_arg "Lexer: location function"; -value loct_create () = (ref (Array.create 1024 None), ref False); +value locerr () = invalid_arg "Lexer: flocation function"; + +value tsz = 256; (* up to 2^29 entries on a 32-bit machine, 2^61 on 64-bit *) + +value loct_create () = (ref [| |], 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 + if i < 0 || i/tsz >= Array.length loct.val then None + else if loct.val.(i/tsz) = [| |] then + if ov.val then Some (nowhere, nowhere) else None + else Array.unsafe_get (Array.unsafe_get loct.val (i/tsz)) (i mod tsz) 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 + +value loct_add (loct, ov) i loc = do { + while i/tsz >= Array.length loct.val && (not ov.val) do { + let new_tmax = Array.length loct.val * 2 + 1 in if new_tmax < Sys.max_array_length then do { - let new_loct = Array.create new_tmax None in + let new_loct = Array.make new_tmax [| |] 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 -; + loct.val := new_loct + } else ov.val := True + }; + if not(ov.val) then do { + if loct.val.(i/tsz) = [| |] then + loct.val.(i/tsz) := Array.make tsz None + else (); + loct.val.(i/tsz).(i mod tsz) := Some loc + } else () +}; -value make_stream_and_location next_token_loc = +value make_stream_and_flocation next_token_loc = let loct = loct_create () in let ts = Stream.from @@ -79,7 +103,7 @@ value make_stream_and_location next_token_loc = ; value lexer_func_of_parser next_token_loc cs = - make_stream_and_location (fun () -> next_token_loc cs) + make_stream_and_flocation (fun () -> next_token_loc cs) ; value lexer_func_of_ocamllex lexfun cs = @@ -90,10 +114,10 @@ value lexer_func_of_ocamllex lexfun cs = in let next_token_loc _ = let tok = lexfun lb in - let loc = (Lexing.lexeme_start lb, Lexing.lexeme_end lb) in + let loc = (Lexing.lexeme_start_p lb, Lexing.lexeme_end_p lb) in (tok, loc) in - make_stream_and_location next_token_loc + make_stream_and_flocation next_token_loc ; (* Char and string tokens to real chars and string *) @@ -133,25 +157,25 @@ value rec backslash s i = | 'x' -> backslash1h s (i + 1) | _ -> raise Not_found ] and backslash1 cod s i = - if i = String.length s then ('\\', i - 1) + if i = String.length s then raise Not_found else match s.[i] with [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> ('\\', i - 1) ] + | _ -> raise Not_found ] and backslash2 cod s i = - if i = String.length s then ('\\', i - 2) + if i = String.length s then raise Not_found else match s.[i] with [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1) - | _ -> ('\\', i - 2) ] + | _ -> raise Not_found ] and backslash1h s i = - if i = String.length s then ('\\', i - 1) + if i = String.length s then raise Not_found else match s.[i] with [ '0'..'9' as c -> backslash2h (valch c) s (i + 1) | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1) | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1) - | _ -> ('\\', i - 1) ] + | _ -> raise Not_found ] and backslash2h cod s i = if i = String.length s then ('\\', i - 2) else @@ -159,7 +183,7 @@ and backslash2h cod s i = [ '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) ] + | _ -> raise Not_found ] ; value rec skip_indent s i = @@ -188,25 +212,33 @@ value eval_char s = else failwith "invalid char token" ; -value eval_string s = +value eval_string (bp, ep) s = loop 0 0 where rec loop len i = if i = String.length s then get_buff len else let (len, i) = if s.[i] = '\\' then let i = i + 1 in - if i = String.length s then failwith "invalid string token" - else if s.[i] = '"' then (store len '"', i + 1) - else - match s.[i] with - [ '\010' -> (len, skip_indent s (i + 1)) - | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1))) - | c -> - try - let (c, i) = backslash s i in - (store len c, i) - with - [ Not_found -> (store (store len '\\') c, i + 1) ] ] + if i = String.length s then failwith "invalid string token" else + if s.[i] = '"' then (store len '"', i + 1) else + match s.[i] with + [ '\010' -> (len, skip_indent s (i + 1)) + | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1))) + | c -> + try + let (c, i) = backslash s i in + (store len c, i) + with + [ Not_found -> do { + let txt = "Invalid backslash escape in string" in + let pos = bp.Lexing.pos_cnum - bp.Lexing.pos_bol + i in + if bp.Lexing.pos_fname = "" then + Printf.eprintf "Warning: line %d, chars %d-%d: %s\n" + bp.Lexing.pos_lnum pos (pos + 1) txt + else + Printf.eprintf "Warning: File \"%s\", line %d, chars %d-%d: %s\n" + bp.Lexing.pos_fname bp.Lexing.pos_lnum pos (pos + 1) txt; + (store (store len '\\') c, i + 1) } ] ] else (store len s.[i], i + 1) in loop len i diff --git a/camlp4/lib/token.mli b/camlp4/lib/token.mli index 9402a000..9244a86c 100644 --- a/camlp4/lib/token.mli +++ b/camlp4/lib/token.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: token.mli,v 1.4 2003/07/10 12:28:25 michel Exp $ *) +(* $Id: token.mli,v 1.6 2004/05/12 15:22:42 mauny Exp $ *) (** Lexers for Camlp4 grammars. @@ -33,11 +33,19 @@ exception Error of string; (** {6 Lexer type} *) -type location = (int * int); -type location_function = int -> location; +type flocation = (Lexing.position * Lexing.position); + +value nowhere : Lexing.position; +value dummy_loc : flocation; + +value make_loc : (int * int) -> flocation; +value succ_pos : Lexing.position -> Lexing.position; +value lt_pos : Lexing.position -> Lexing.position -> bool; + +type flocation_function = int -> flocation; (** 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); +type lexer_func 'te = Stream.t char -> (Stream.t 'te * flocation_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. *) @@ -48,7 +56,7 @@ type glexer 'te = tok_removing : pattern -> unit; tok_match : pattern -> 'te -> string; tok_text : pattern -> string; - tok_comm : mutable option (list location) } + tok_comm : mutable option (list flocation) } ; (** The type for a lexer used by Camlp4 grammars. - The field [tok_func] is the main lexer function. See [lexer_func] @@ -96,24 +104,29 @@ value default_match : pattern -> (string * string) -> string; as well. *) value lexer_func_of_parser : - (Stream.t char -> ('te * location)) -> lexer_func 'te; + (Stream.t char -> ('te * flocation)) -> 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); +value make_stream_and_flocation : + (unit -> ('te * flocation)) -> (Stream.t 'te * flocation_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] *) + (** Convert a char token, where the escape sequences (backslashes) + remain to be interpreted; raise [Failure] if an + incorrect backslash sequence is found; [Token.eval_char (Char.escaped c)] + returns [c] *) + +value eval_string : flocation -> string -> string; + (** Convert a string token, where the escape sequences (backslashes) + remain to be interpreted; issue a warning if an incorrect + backslash sequence is found; + [Token.eval_string loc (String.escaped s)] returns [s] *) (**/**) diff --git a/camlp4/man/Makefile.Mac b/camlp4/man/Makefile.Mac deleted file mode 100644 index 39a82bce..00000000 --- a/camlp4/man/Makefile.Mac +++ /dev/null @@ -1,31 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: 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/meta/.depend b/camlp4/meta/.depend index 737ea5ec..977947f5 100644 --- a/camlp4/meta/.depend +++ b/camlp4/meta/.depend @@ -1,9 +1,7 @@ -pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/reloc.cmi +pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/reloc.cmx pa_extend_m.cmo: pa_extend.cmo pa_extend_m.cmx: pa_extend.cmx -pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi @@ -12,5 +10,7 @@ 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 +q_MLast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi \ + ../camlp4/reloc.cmi +q_MLast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx \ + ../camlp4/reloc.cmx diff --git a/camlp4/meta/Makefile b/camlp4/meta/Makefile index 22e6bf0e..90564dff 100644 --- a/camlp4/meta/Makefile +++ b/camlp4/meta/Makefile @@ -1,4 +1,4 @@ -# $Id: Makefile,v 1.13 2003/08/29 12:15:15 xleroy Exp $ +# $Id: Makefile,v 1.15 2004/05/25 12:44:22 mauny Exp $ include ../config/Makefile @@ -10,7 +10,7 @@ CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx) SHELL=/bin/sh COUT=$(OBJS) camlp4r$(EXE) -COPT=camlp4r.opt +COPT=$(OBJSX) camlp4r.opt all: $(COUT) opt: $(COPT) @@ -49,11 +49,7 @@ install: cp camlp4r$(EXE) "$(BINDIR)/." if test -f camlp4r.opt; then \ cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\ - for target in $(OBJSX) $(OBJSX:.cmx=.$(O)) ; do \ - if test -f $$target; then \ - cp $$target "$(LIBDIR)/camlp4/."; \ - fi; \ - done; \ + cp $(OBJSX) $(OBJSX:.cmx=.$(O)) "$(LIBDIR)/camlp4/."; \ fi include .depend diff --git a/camlp4/meta/Makefile.Mac b/camlp4/meta/Makefile.Mac deleted file mode 100644 index ee4cd4f8..00000000 --- a/camlp4/meta/Makefile.Mac +++ /dev/null @@ -1,50 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: 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 deleted file mode 100644 index 29675238..00000000 --- a/camlp4/meta/Makefile.Mac.depend +++ /dev/null @@ -1,12 +0,0 @@ -pa_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_extend_m.cmoÄ ::camlp4:mLast.cmi pa_extend.cmo -pa_extend_m.cmxÄ ::camlp4:mLast.cmi pa_extend.cmx -pa_macro.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_macro.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -q_MLast.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi -q_MLast.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx diff --git a/camlp4/meta/mk_q_MLast.sh b/camlp4/meta/mk_q_MLast.sh deleted file mode 100755 index a04c91f0..00000000 --- a/camlp4/meta/mk_q_MLast.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/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 index ab33cad4..a3277489 100644 --- a/camlp4/meta/pa_extend.ml +++ b/camlp4/meta/pa_extend.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pa_extend.ml,v 1.32 2003/07/10 12:28:26 michel Exp $ *) +(* $Id: pa_extend.ml,v 1.33 2004/05/12 15:22:43 mauny Exp $ *) open Stdpp; @@ -22,9 +22,9 @@ Pcaml.add_option "-split_ext" (Arg.Set split_ext) Pcaml.add_option "-split_gext" (Arg.Set split_ext) "Old name for the option -split_ext."; -type loc = (int * int); +type loc = (Lexing.position * Lexing.position); -type name 'e = { expr : 'e; tvar : string; loc : (int * int) }; +type name 'e = { expr : 'e; tvar : string; loc : loc }; type styp = [ STlid of loc and string @@ -163,7 +163,10 @@ module MetaAction = in failwith (f ^ ", not impl: " ^ desc) ; - value loc = (0, 0); + value loc = + let nowhere = + { (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in + (nowhere, nowhere); value rec mlist mf = fun [ [] -> <:expr< [] >> @@ -179,7 +182,10 @@ module MetaAction = [ False -> <:expr< False >> | True -> <:expr< True >> ] ; - value mloc = <:expr< (0, 0) >>; + value mloc = + <:expr< let nowhere = + { (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in + (nowhere, nowhere) >>; value rec mexpr = fun [ MLast.ExAcc loc e1 e2 -> @@ -355,7 +361,10 @@ value quotify_action psl act = (fun e ps -> match ps.pattern with [ Some <:patt< ($list:pl$) >> -> - let loc = (0, 0) in + let loc = + let nowhere = + { (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in + (nowhere, nowhere) in let pname = pname_of_ptuple pl in let (pl1, el1) = let (l, _) = @@ -453,7 +462,7 @@ value text_of_action loc psl rtvar act tvar = [ 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 e = <:expr< fun [ ($locid$ : (Lexing.position * Lexing.position)) -> ($act$ : '$rtvar$) ] >> in let txt = List.fold_left (fun txt ps -> @@ -724,6 +733,8 @@ value text_of_functorial_extend loc gmod gl el = let_in_of_extend loc gmod True gl el args ; +value zero_loc = {(Lexing.dummy_pos) with Lexing.pos_cnum = 0}; + open Pcaml; value symbol = Grammar.Entry.create gram "symbol"; value semi_sep = @@ -899,13 +910,13 @@ EXTEND string: [ [ s = STRING -> <:expr< $str:s$ >> | i = ANTIQUOT -> - let shift = fst loc + String.length "$" in + let shift = Reloc.shift_pos (String.length "$") (fst loc) 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 ] + raise_with_loc (Reloc.adjust_loc shift (bp,ep)) exc ] in - Pcaml.expr_reloc (fun (bp, ep) -> (shift + bp, shift + ep)) 0 e ] ] + Pcaml.expr_reloc (fun (bp, ep) -> (Reloc.adjust_loc shift (bp,ep))) zero_loc e ] ] ; END; diff --git a/camlp4/meta/pa_ifdef.ml b/camlp4/meta/pa_ifdef.ml deleted file mode 100644 index 980c85af..00000000 --- a/camlp4/meta/pa_ifdef.ml +++ /dev/null @@ -1,85 +0,0 @@ -(* 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 index 4f5dd823..7ca72a67 100644 --- a/camlp4/meta/pa_macro.ml +++ b/camlp4/meta/pa_macro.ml @@ -1,5 +1,5 @@ (* camlp4r *) -(* $Id: pa_macro.ml,v 1.1 2003/07/10 12:28:27 michel Exp $ *) +(* $Id: pa_macro.ml,v 1.2.4.6 2004/07/02 09:37:16 doligez Exp $ *) (* Added statements: @@ -9,33 +9,43 @@ Added statements: DEFINE DEFINE = DEFINE () = - IFDEF THEN END - IFDEF THEN ELSE END - IFNDEF THEN END - IFNDEF THEN ELSE END + IFDEF THEN (END | ENDIF) + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) + INCLUDE In expressions: - IFDEF THEN ELSE END - IFNDEF THEN ELSE END + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) __FILE__ __LOCATION__ In patterns: - IFDEF THEN ELSE END - IFNDEF THEN ELSE END + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) As Camlp4 options: - -D - -U + -D define + -U undefine it + -I

add to the search path for INCLUDE'd files 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 toplevel statement INCLUDE can be used to include a + file containing macro definitions; note that files included in such + a way can not have any non-macro toplevel items. The included files + are looked up in directories passed in via the -I option, falling + back to the current directory. + The expression __FILE__ returns the current compiled file name. The expression __LOCATION__ returns the current location of itself. @@ -50,7 +60,8 @@ type item_or_def 'a = [ SdStr of 'a | SdDef of string and option (list string * MLast.expr) | SdUnd of string - | SdNop ] + | SdITE of string and list (item_or_def 'a) and list (item_or_def 'a) + | SdInc of string ] ; value rec list_remove x = @@ -64,10 +75,13 @@ value defined = ref []; value is_defined i = List.mem_assoc i defined.val; -value loc = (0, 0); +value loc = + let nowhere = + { (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in + (nowhere, nowhere); value subst mloc env = - loop where rec loop = + let rec loop = fun [ <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> let pel = List.map (fun (p, e) -> (p, loop e)) pel in @@ -75,14 +89,29 @@ value subst mloc env = | <:expr< if $e1$ then $e2$ else $e3$ >> -> <:expr< if $loop e1$ then $loop e2$ else $loop e3$ >> | <:expr< $e1$ $e2$ >> -> <:expr< $loop e1$ $loop e2$ >> + | <:expr< fun $args$ -> $e$ >> -> <:expr< fun $args$ -> $loop e$ >> + | <:expr< fun [ $list: peoel$ ] >> -> <:expr< fun [ $list: (List.map loop_peoel peoel)$ ] >> | <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e -> try <:expr< $anti:List.assoc x env$ >> with [ Not_found -> e ] | <:expr< ($list:x$) >> -> <:expr< ($list:List.map loop x$) >> + | <:expr< do {$list:x$} >> -> <:expr< do {$list:List.map loop x$} >> | <:expr< { $list:pel$ } >> -> let pel = List.map (fun (p, e) -> (p, loop e)) pel in <:expr< { $list:pel$ } >> + | <:expr< match $e$ with [ $list:peoel$ ] >> -> + <:expr< match $loop e$ with [ $list: (List.map loop_peoel peoel)$ ] >> + | <:expr< try $e$ with [ $list:pel$ ] >> -> + let loop' = fun + [ (p, Some e1, e2) -> (p, Some (loop e1), loop e2) + | (p, None, e2) -> (p, None, loop e2) ] in + <:expr< try $loop e$ with [ $list: (List.map loop' pel)$ ] >> | e -> e ] + and loop_peoel = + fun + [ (p, Some e1, e2) -> (p, Some (loop e1), loop e2) + | (p, None, e2) -> (p, None, loop e2) ] + in loop ; value substp mloc env = @@ -96,6 +125,7 @@ value substp mloc env = try <:patt< $anti:List.assoc x env$ >> with [ Not_found -> <:patt< $uid:x$ >> ] | <:expr< $int:x$ >> -> <:patt< $int:x$ >> + | <:expr< $str:s$ >> -> <:patt< $str:s$ >> | <:expr< ($list:x$) >> -> <:patt< ($list:List.map loop x$) >> | <:expr< { $list:pel$ } >> -> let ppl = List.map (fun (p, e) -> (p, loop e)) pel in @@ -119,12 +149,12 @@ value define eo x = [ Some ([], e) -> EXTEND expr: LEVEL "simple" - [ [ UIDENT $x$ -> Pcaml.expr_reloc (fun _ -> loc) 0 e ] ] + [ [ UIDENT $x$ -> Pcaml.expr_reloc (fun _ -> loc) (fst loc) e ] ] ; patt: LEVEL "simple" [ [ UIDENT $x$ -> let p = substp loc [] e in - Pcaml.patt_reloc (fun _ -> loc) 0 p ] ] + Pcaml.patt_reloc (fun _ -> loc) (fst loc) p ] ] ; END | Some (sl, e) -> @@ -139,7 +169,7 @@ value define eo x = 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 + Pcaml.expr_reloc (fun _ -> loc) (fst loc) e else incorrect_number loc el sl ] ] ; @@ -153,7 +183,7 @@ value define eo x = 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 + Pcaml.patt_reloc (fun _ -> loc) (fst loc) p else incorrect_number loc pl sl ] ] ; @@ -185,34 +215,87 @@ value undef x = [ Not_found -> () ] ; +(* This is a list of directories to search for INCLUDE statements. *) +value include_dirs = ref [] +; + +(* Add something to the above, make sure it ends with a slash. *) +value add_include_dir str = + if str <> "" then + let str = + if String.get str ((String.length str)-1) = '/' + then str else str ^ "/" + in include_dirs.val := include_dirs.val @ [str] + else () +; + +value smlist = Grammar.Entry.create Pcaml.gram "smlist" +; + +value parse_include_file = + let dir_ok file dir = Sys.file_exists (dir ^ file) in + fun file -> + let file = + try (List.find (dir_ok file) (include_dirs.val @ ["./"])) ^ file + with [ Not_found -> file ] + in + let st = Stream.of_channel (open_in file) in + let old_input = Pcaml.input_file.val in + do { + Pcaml.input_file.val := file; + let items = Grammar.Entry.parse smlist st in + do { Pcaml.input_file.val := old_input; items } } +; + +value rec execute_macro = fun +[ SdStr i -> [i] +| SdDef x eo -> do { define eo x; [] } +| SdUnd x -> do { undef x; [] } +| SdITE i l1 l2 -> + execute_macro_list (if is_defined i then l1 else l2) +| SdInc f -> execute_macro_list (parse_include_file f) ] + +and execute_macro_list = fun +[ [] -> [] +| [hd::tl] -> (* The evaluation order is important here *) + let il1 = execute_macro hd in + let il2 = execute_macro_list tl in + il1 @ il2 ] +; + EXTEND - GLOBAL: expr patt str_item sig_item; + GLOBAL: expr patt str_item sig_item smlist; str_item: FIRST [ [ x = macro_def -> - match x with - [ SdStr [si] -> si - | SdStr sil -> <:str_item< declare $list:sil$ end >> - | SdDef x eo -> do { define eo x; <:str_item< declare end >> } - | SdUnd x -> do { undef x; <:str_item< declare end >> } - | SdNop -> <:str_item< declare end >> ] ] ] + match execute_macro x with + [ [si] -> si + | sil -> <:str_item< declare $list:sil$ end >> ] ] ] ; macro_def: [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def | "UNDEF"; i = uident -> SdUnd i - | "IFDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" -> - if is_defined i then d else SdNop - | "IFDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE"; - d2 = str_item_or_macro; "END" -> - if is_defined i then d1 else d2 - | "IFNDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" -> - if is_defined i then SdNop else d - | "IFNDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE"; - d2 = str_item_or_macro; "END" -> - if is_defined i then d2 else d1 ] ] + | "IFDEF"; i = uident; "THEN"; dl = smlist; _ = endif -> + SdITE i dl [] + | "IFDEF"; i = uident; "THEN"; dl1 = smlist; "ELSE"; + dl2 = smlist; _ = endif -> + SdITE i dl1 dl2 + | "IFNDEF"; i = uident; "THEN"; dl = smlist; _ = endif -> + SdITE i [] dl + | "IFNDEF"; i = uident; "THEN"; dl1 = smlist; "ELSE"; + dl2 = smlist; _ = endif -> + SdITE i dl2 dl1 + | "INCLUDE"; fname = STRING -> SdInc fname ] ] ; + smlist: + [ [ sml = LIST1 str_item_or_macro -> sml ] ] + ; + endif: + [ [ "END" -> () + | "ENDIF" -> () ] ] + ; str_item_or_macro: [ [ d = macro_def -> d - | si = LIST1 str_item -> SdStr si ] ] + | si = str_item -> SdStr si ] ] ; opt_macro_value: [ [ "("; pl = LIST1 LIDENT SEP ","; ")"; "="; e = expr -> Some (pl, e) @@ -220,22 +303,22 @@ EXTEND | -> None ] ] ; expr: LEVEL "top" - [ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> + [ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; _ = endif -> if is_defined i then e1 else e2 - | "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> + | "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; _ = endif -> if is_defined i then e2 else e1 ] ] ; expr: LEVEL "simple" [ [ 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 + let bp = string_of_int ((fst loc).Lexing.pos_cnum) in + let ep = string_of_int ((snd loc).Lexing.pos_cnum) in <:expr< ($int:bp$, $int:ep$) >> ] ] ; patt: - [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" -> + [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; _ = endif -> if is_defined i then p1 else p2 - | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" -> + | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; _ = endif -> if is_defined i then p2 else p1 ] ] ; uident: @@ -249,3 +332,6 @@ Pcaml.add_option "-D" (Arg.String (define None)) Pcaml.add_option "-U" (Arg.String undef) " Undefine for IFDEF instruction." ; +Pcaml.add_option "-I" (Arg.String add_include_dir) + " Add a directory to INCLUDE search path." +; diff --git a/camlp4/meta/pa_r.ml b/camlp4/meta/pa_r.ml index c61eec69..169a986a 100644 --- a/camlp4/meta/pa_r.ml +++ b/camlp4/meta/pa_r.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pa_r.ml,v 1.55 2003/10/02 12:33:43 mauny Exp $ *) +(* $Id: pa_r.ml,v 1.59 2004/05/25 18:53:18 mauny Exp $ *) open Stdpp; open Pcaml; @@ -323,7 +323,10 @@ EXTEND "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$ } >> ] + <:expr< while $e$ do { $list:seq$ } >> + | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> + (* <:expr< object $opt:cspo$ $list:cf$ end >> *) + MLast.ExObj loc cspo cf ] | "where" [ e = SELF; "where"; rf = OPT "rec"; lb = let_binding -> <:expr< let $opt:o2b rf$ $list:[lb]$ in $e$ >> ] @@ -392,9 +395,8 @@ EXTEND 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$ } >> + | "{"; "("; 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 ","; ")" -> @@ -735,8 +737,14 @@ EXTEND ; ctyp: LEVEL "simple" [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; ml = LIST0 field SEP ";"; v = OPT ".."; ">" -> - <:ctyp< < $list:ml$ $opt:o2b v$ > >> ] ] + | "<"; (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) ] ] @@ -760,6 +768,10 @@ EXTEND | "["; "<"; rfl = row_field_list; "]" -> <:ctyp< [ < $list:rfl$ ] >> | "["; "<"; rfl = row_field_list; ">"; ntl = LIST1 name_tag; "]" -> + <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> + | "[<"; rfl = row_field_list; "]" -> + <:ctyp< [ < $list:rfl$ ] >> + | "[<"; rfl = row_field_list; ">"; ntl = LIST1 name_tag; "]" -> <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] ; row_field_list: @@ -901,10 +913,11 @@ EXTEND let x = try let i = String.index x ':' in - (int_of_string (String.sub x 0 i), + ({ (Lexing.dummy_pos) with Lexing.pos_cnum = int_of_string (String.sub x 0 i) } + , String.sub x (i + 1) (String.length x - i - 1)) with - [ Not_found | Failure _ -> (0, x) ] + [ Not_found | Failure _ -> ({(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x) ] in Pcaml.handle_expr_locate loc x | x = QUOTATION -> @@ -923,10 +936,11 @@ EXTEND let x = try let i = String.index x ':' in - (int_of_string (String.sub x 0 i), + ({(Lexing.dummy_pos) with Lexing.pos_cnum = int_of_string (String.sub x 0 i)} + , String.sub x (i + 1) (String.length x - i - 1)) with - [ Not_found | Failure _ -> (0, x) ] + [ Not_found | Failure _ -> ({(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x) ] in Pcaml.handle_patt_locate loc x | x = QUOTATION -> diff --git a/camlp4/meta/q_MLast.ml b/camlp4/meta/q_MLast.ml index 493a1100..ad999977 100644 --- a/camlp4/meta/q_MLast.ml +++ b/camlp4/meta/q_MLast.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: q_MLast.ml,v 1.53 2003/10/02 12:33:43 mauny Exp $ *) +(* $Id: q_MLast.ml,v 1.56 2004/05/25 18:53:18 mauny Exp $ *) value gram = Grammar.gcreate (Plexer.gmake ()); @@ -30,7 +30,10 @@ module Qast = | Loc | Antiquot of MLast.loc and string ] ; - value loc = (0, 0); + value loc = + let nowhere = + {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in + (nowhere,nowhere); value rec to_expr = fun [ Node n al -> @@ -56,7 +59,7 @@ module Qast = 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) ] + raise (Stdpp.Exc_located (Reloc.adjust_loc (fst loc) (bp,ep)) exc) ] in <:expr< $anti:e$ >> ] and to_expr_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_expr a); @@ -83,7 +86,7 @@ module Qast = 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) ] + raise (Stdpp.Exc_located (Reloc.adjust_loc (fst loc) (bp, ep)) exc) ] in <:patt< $anti:p$ >> ] and to_patt_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_patt a); @@ -95,7 +98,7 @@ value antiquot k (bp, ep) x = if k = "" then String.length "$" else String.length "$" + String.length k + String.length ":" in - Qast.Antiquot (shift + bp, shift + ep) x + Qast.Antiquot (Reloc.shift_pos shift bp, Reloc.shift_pos (-1) ep) x ; value sig_item = Grammar.Entry.create gram "signature item"; @@ -123,6 +126,9 @@ 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_INT32 = Grammar.Entry.create gram "a_INT32"; +value a_INT64 = Grammar.Entry.create gram "a_INT64"; +value a_NATIVEINT = Grammar.Entry.create gram "a__NATIVEINT"; 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"; @@ -254,7 +260,7 @@ 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) + Pcaml.warning.val (Lexing.dummy_pos, Reloc.shift_pos 1 Lexing.dummy_pos) (Printf.sprintf "use of syntax of variants types deprecated since version 3.05"); } @@ -265,7 +271,7 @@ 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) + Pcaml.warning.val (Lexing.dummy_pos, Reloc.shift_pos 1 Lexing.dummy_pos) (Printf.sprintf "use of syntax of sequences deprecated since version 3.01.1"); } @@ -623,6 +629,9 @@ EXTEND [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-."]; e] ] | "simple" [ s = a_INT -> Qast.Node "ExInt" [Qast.Loc; s] + | s = a_INT32 -> Qast.Node "ExInt32" [Qast.Loc; s] + | s = a_INT64 -> Qast.Node "ExInt64" [Qast.Loc; s] + | s = a_NATIVEINT -> Qast.Node "ExNativeInt" [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] @@ -712,10 +721,16 @@ EXTEND [ 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_INT32 -> Qast.Node "PaInt32" [Qast.Loc; s] + | s = a_INT64 -> Qast.Node "PaInt64" [Qast.Loc; s] + | s = a_NATIVEINT -> Qast.Node "PaNativeInt" [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_INT32 -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s + | "-"; s = a_INT64 -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s + | "-"; s = a_NATIVEINT -> 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 "[]"] @@ -1026,6 +1041,13 @@ EXTEND [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)))] + | "[<"; 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)))] ] ] ; @@ -1332,6 +1354,21 @@ EXTEND | a = ANTIQUOT -> antiquot "" loc a | s = INT -> Qast.Str s ] ] ; + a_INT32: + [ [ a = ANTIQUOT "int32" -> antiquot "int32" loc a + | a = ANTIQUOT -> antiquot "" loc a + | s = INT32 -> Qast.Str s ] ] + ; + a_INT64: + [ [ a = ANTIQUOT "int64" -> antiquot "int64" loc a + | a = ANTIQUOT -> antiquot "" loc a + | s = INT64 -> Qast.Str s ] ] + ; + a_NATIVEINT: + [ [ a = ANTIQUOT "nativeint" -> antiquot "nativeint" loc a + | a = ANTIQUOT -> antiquot "" loc a + | s = NATIVEINT -> Qast.Str s ] ] + ; a_FLOAT: [ [ a = ANTIQUOT "flo" -> antiquot "flo" loc a | a = ANTIQUOT -> antiquot "" loc a diff --git a/camlp4/ocaml_src/camlp4/.depend b/camlp4/ocaml_src/camlp4/.depend index 00ddb5ad..3c0f8e10 100644 --- a/camlp4/ocaml_src/camlp4/.depend +++ b/camlp4/ocaml_src/camlp4/.depend @@ -7,14 +7,12 @@ 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 + pcaml.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 -crc.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi -crc.cmx: $(OTOP)/otherlibs/dynlink/dynlink.cmx -pcaml.cmo: ast2pt.cmi mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmx: ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi + pcaml.cmx ast2pt.cmi +pcaml.cmo: mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi +pcaml.cmx: mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi quotation.cmo: mLast.cmi quotation.cmi quotation.cmx: mLast.cmi quotation.cmi reloc.cmo: mLast.cmi reloc.cmi diff --git a/camlp4/ocaml_src/camlp4/Makefile b/camlp4/ocaml_src/camlp4/Makefile index 0e5d0576..6abcb864 100644 --- a/camlp4/ocaml_src/camlp4/Makefile +++ b/camlp4/ocaml_src/camlp4/Makefile @@ -9,8 +9,8 @@ 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 +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 spretty.cmo reloc.cmo pcaml.cmo ast2pt.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 spretty.cmx reloc.cmx pcaml.cmx ast2pt.cmx argl.cmx OBJS=../odyl/odyl.cma camlp4.cma CAMLP4M= @@ -18,23 +18,35 @@ CAMLP4=camlp4$(EXE) CAMLP4OPT=phony all: $(CAMLP4) -opt: $(OBJS:.cma=.cmxa) + +opt: opt$(PROFILING) + +optnoprof: $(OBJS:.cma=.cmxa) + +optprof: optnoprof $(OBJS:.cma=.p.cmxa) + optp4: $(CAMLP4OPT) $(CAMLP4): $(OBJS) ../odyl/odyl.cmo - $(OCAMLC) $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo -linkall -o $(CAMLP4) + $(OCAMLC) -linkall -o $@ $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo $(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx - $(OCAMLOPT) $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx -linkall -o $(CAMLP4OPT) + $(OCAMLOPT) -o $@ $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx $(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml - $(OCAMLOPT) -c $(OTOP)/utils/config.ml + $(OCAMLOPT) -I $(OTOP)/utils -c $(OTOP)/utils/config.ml + +$(OTOP)/utils/config.p.cmx: $(OTOP)/utils/config.ml + $(OCAMLOPT) -I $(OTOP)/utils -p -c -o $@ $(OTOP)/utils/config.ml camlp4.cma: $(CAMLP4_OBJS) - $(OCAMLC) $(LINKFLAGS) $(CAMLP4_OBJS) -a -o camlp4.cma + $(OCAMLC) $(LINKFLAGS) -a -linkall -o $@ $(CAMLP4_OBJS) camlp4.cmxa: $(CAMLP4_XOBJS) - $(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa + $(OCAMLOPT) $(LINKFLAGS) -a -linkall -o $@ $(CAMLP4_XOBJS) + +camlp4.p.cmxa: $(CAMLP4_XOBJS:.cmx=.p.cmx) + $(OCAMLOPT) $(LINKFLAGS) -a -linkall -o $@ $(CAMLP4_XOBJS:.cmx=.p.cmx) clean:: rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt @@ -63,9 +75,8 @@ install: cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/." cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/." cp camlp4.cma $(LIBDIR)/camlp4/. - if [ -f camlp4.cmxa ]; \ - then cp camlp4.cmxa camlp4.$(A) $(LIBDIR)/camlp4/.; \ - else : ; \ - fi + for f in camlp4.$(A) camlp4.p.$(A) camlp4.cmxa camlp4.p.cmxa; do \ + test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true; \ + done include .depend diff --git a/camlp4/ocaml_src/camlp4/Makefile.Mac b/camlp4/ocaml_src/camlp4/Makefile.Mac deleted file mode 100644 index b7561d8c..00000000 --- a/camlp4/ocaml_src/camlp4/Makefile.Mac +++ /dev/null @@ -1,69 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -I ::odyl: -I :::boot: -I "{OTOP}utils:" -I "{OTOP}parsing:" ¶ - -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} -INTERFACES = -I "{OLIBDIR}" Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak ¶ - -I :::boot: Extfold Extfun Fstream ¶ - Gramext Grammar Plexer ¶ - Stdpp Token -I "{OTOP}utils:" Config Warnings ¶ - -I "{OTOP}parsing:" Asttypes Location Longident Parsetree ¶ - -I : Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF = "{OTOP}utils:config.cmi" "{OTOP}utils:warnings.cmi" ¶ - "{OTOP}parsing:asttypes.cmi" "{OTOP}parsing:location.cmi" ¶ - "{OTOP}parsing:longident.cmi" "{OTOP}parsing:parsetree.cmi" ¶ - ast2pt.cmo mLast.cmi pcaml.cmi spretty.cmi ¶ - quotation.cmi -CAMLP4_OBJS = :::boot:stdpp.cmo :::boot:token.cmo :::boot:plexer.cmo ¶ - :::boot:gramext.cmo :::boot:grammar.cmo :::boot:extfold.cmo :::boot:extfun.cmo ¶ - :::boot:fstream.cmo "{OTOP}utils:config.cmo" ¶ - quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo ¶ - argl.cmo crc.cmo -OBJS = ::odyl:odyl.cma camlp4.cma -XOBJS = camlp4.cmxa -CAMLP4M = - -CAMLP4 = camlp4 - -all Ä {CAMLP4} - -{CAMLP4} Ä {OBJS} ::odyl:odyl.cmo - {OCAMLC} {OBJS} {CAMLP4M} ::odyl:odyl.cmo -linkall -o {CAMLP4} - -camlp4.cma Ä {CAMLP4_OBJS} - {OCAMLC} {LINKFLAGS} {CAMLP4_OBJS} -a -o camlp4.cma - -clean ÄÄ - delete -i {CAMLP4} - -{dependrule} - -promote Ä - duplicate -y {CAMLP4} :::boot: - -compare Ä - for i in {CAMLP4} - equal -s {i} :::boot:{i} || exit 1 - end - -install Ä - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {CAMLP4} "{BINDIR}" - duplicate -y mLast.mli quotation.mli pcaml.mli spretty.mli "{P4LIBDIR}" - duplicate -y mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi ¶ - "{P4LIBDIR}" - duplicate -y camlp4.cma "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/ocaml_src/camlp4/Makefile.Mac.depend b/camlp4/ocaml_src/camlp4/Makefile.Mac.depend deleted file mode 100644 index 3665195f..00000000 --- a/camlp4/ocaml_src/camlp4/Makefile.Mac.depend +++ /dev/null @@ -1,15 +0,0 @@ -pcaml.cmiÄ mLast.cmi spretty.cmi -quotation.cmiÄ mLast.cmi -reloc.cmiÄ mLast.cmi -argl.cmoÄ ast2pt.cmo mLast.cmi pcaml.cmi -argl.cmxÄ ast2pt.cmx mLast.cmi pcaml.cmx -ast2pt.cmoÄ mLast.cmi -ast2pt.cmxÄ mLast.cmi -pcaml.cmoÄ ast2pt.cmo mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmxÄ ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi -quotation.cmoÄ mLast.cmi quotation.cmi -quotation.cmxÄ mLast.cmi quotation.cmi -reloc.cmoÄ mLast.cmi reloc.cmi -reloc.cmxÄ mLast.cmi reloc.cmi -spretty.cmoÄ spretty.cmi -spretty.cmxÄ spretty.cmi diff --git a/camlp4/ocaml_src/camlp4/argl.ml b/camlp4/ocaml_src/camlp4/argl.ml index 0f6ac98c..c85c1c3e 100644 --- a/camlp4/ocaml_src/camlp4/argl.ml +++ b/camlp4/ocaml_src/camlp4/argl.ml @@ -128,7 +128,9 @@ 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) + else + eprintf "At location %d-%d\n" (fst loc).Lexing.pos_cnum + (snd loc).Lexing.pos_cnum ;; let print_warning loc s = print_location loc; eprintf "%s\n" s;; @@ -215,6 +217,10 @@ let file_kind_of_name name = else raise (Arg.Bad ("don't know what to do with " ^ name)) ;; +let print_version_string () = + print_string Pcaml.version; print_newline (); exit 0 +;; + let print_version () = eprintf "Camlp4 version %s\n" Pcaml.version; flush stderr; exit 0 ;; @@ -291,14 +297,7 @@ let print_usage_list 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"; +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 = @@ -318,9 +317,7 @@ Other options: let warn_noassert () = eprintf "\ -camlp4 warning: option -noassert is obsolete -You should give the -noassert option to the ocaml compiler instead. -" +camlp4 warning: option -noassert is obsoleteYou should give the -noassert option to the ocaml compiler instead." ;; let initial_spec_list = @@ -340,7 +337,9 @@ let initial_spec_list = " 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."] + "-v", Arg.Unit print_version, "Print Camlp4 version and exit."; + "-version", Arg.Unit print_version_string, + "Print Camlp4 version number and exit."] ;; let anon_fun x = Pcaml.input_file := x; file_kind := file_kind_of_name x;; @@ -399,7 +398,10 @@ let go () = Stdpp.Exc_located ((bp, ep), exc) -> print_location (bp, ep); exc | _ -> exc in - report_error exc; Format.close_box (); Format.print_newline (); exit 2 + report_error exc; + Format.close_box (); + Format.print_newline (); + raise exc ;; Odyl_main.name := "camlp4";; diff --git a/camlp4/ocaml_src/camlp4/ast2pt.ml b/camlp4/ocaml_src/camlp4/ast2pt.ml index 6839428e..78607552 100644 --- a/camlp4/ocaml_src/camlp4/ast2pt.ml +++ b/camlp4/ocaml_src/camlp4/ast2pt.ml @@ -19,7 +19,7 @@ open Longident;; open Asttypes;; let fast = ref false;; -let no_constructors_arity = ref false;; +let no_constructors_arity = Pcaml.no_constructors_arity;; let get_tag x = if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x @@ -33,7 +33,7 @@ let char_of_char_token loc s = ;; let string_of_string_token loc s = - try Token.eval_string s with + try Token.eval_string loc s with Failure _ as exn -> raise_with_loc loc exn ;; @@ -41,17 +41,23 @@ 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} + {n with + Lexing.pos_fname = + if n.Lexing.pos_fname = "" then + if !glob_fname = "" then !(Pcaml.input_file) else !glob_fname + else n.Lexing.pos_fname} in {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; - Location.loc_ghost = false} + Location.loc_ghost = bp.Lexing.pos_cnum = 0 && ep.Lexing.pos_cnum = 0} ;; let mkghloc (bp, ep) = let loc_at n = - {Lexing.pos_fname = ""; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; - Lexing.pos_cnum = n} + {n with + Lexing.pos_fname = + if n.Lexing.pos_fname = "" then + if !glob_fname = "" then !(Pcaml.input_file) else !glob_fname + else n.Lexing.pos_fname} in {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; Location.loc_ghost = true} @@ -125,19 +131,31 @@ let rec ctyp_fa al = | f -> f, al ;; -let rec ctyp_long_id = - function +let rec ctyp_long_id_prefix t = + match t with TyAcc (_, m, TyLid (_, s)) -> - let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s + error (loc_of_ctyp t) "invalid module expression" | TyAcc (_, m, TyUid (_, s)) -> - let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s + let (is_cls, li) = ctyp_long_id_prefix 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) + let (is_cls, li1) = ctyp_long_id_prefix m1 in + let (_, li2) = ctyp_long_id_prefix m2 in is_cls, Lapply (li1, li2) | TyUid (_, s) -> false, lident s + | TyLid (_, s) -> error (loc_of_ctyp t) "invalid module expression" + | t -> error (loc_of_ctyp t) "invalid module expression" +;; + +let ctyp_long_id t = + match t with + TyAcc (_, m, TyLid (_, s)) -> + let (is_cls, li) = ctyp_long_id_prefix m in is_cls, ldot li s + | TyAcc (_, m, (TyUid (_, s) as t)) -> + error (loc_of_ctyp t) "invalid type name" + | TyApp (_, m1, m2) -> error (loc_of_ctyp t) "invalid type name" + | TyUid (_, s) -> error (loc_of_ctyp t) "invalid type name" | TyLid (_, s) -> false, lident s | TyCls (loc, sl) -> true, long_id_of_string_list loc sl - | t -> error (loc_of_ctyp t) "incorrect type" + | t -> error (loc_of_ctyp t) "invalid type" ;; let rec ctyp = @@ -151,7 +169,7 @@ let rec ctyp = match t1, t2 with t, TyQuo (_, s) -> t, s | TyQuo (_, s), t -> t, s - | _ -> error loc "incorrect alias type" + | _ -> error loc "invalid alias type" in mktyp loc (Ptyp_alias (ctyp t, i)) | TyAny loc -> mktyp loc Ptyp_any @@ -178,7 +196,7 @@ let rec ctyp = | 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, [])) + | TyUid (loc, s) as t -> error (loc_of_ctyp t) "invalid type" | TyVrn (loc, catl, ool) -> let catl = List.map @@ -391,7 +409,7 @@ let rec patt = match p1, p2 with p, PaLid (_, s) -> p, s | PaLid (_, s), p -> p, s - | _ -> error loc "incorrect alias pattern" + | _ -> error loc "invalid alias pattern" in mkpat loc (Ppat_alias (patt p, i)) | PaAnt (_, p) -> patt p @@ -623,6 +641,14 @@ let rec expr = 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)) + | ExObj (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 + mkexp loc (Pexp_object (patt p, cil)) | ExOlb (loc, _, _) -> error loc "labeled expression not allowed here" | ExOvr (loc, iel) -> mkexp loc (Pexp_override (List.map mkideexp iel)) | ExRec (loc, lel, eo) -> diff --git a/camlp4/ocaml_src/camlp4/ast2pt.mli b/camlp4/ocaml_src/camlp4/ast2pt.mli index d64fb6e3..c6aeab29 100644 --- a/camlp4/ocaml_src/camlp4/ast2pt.mli +++ b/camlp4/ocaml_src/camlp4/ast2pt.mli @@ -14,8 +14,8 @@ 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 mkloc : MLast.loc -> Location.t;; +val long_id_of_string_list : MLast.loc -> string list -> Longident.t;; val str_item : MLast.str_item -> Parsetree.structure -> Parsetree.structure;; val interf : MLast.sig_item list -> Parsetree.signature;; diff --git a/camlp4/ocaml_src/camlp4/mLast.mli b/camlp4/ocaml_src/camlp4/mLast.mli index 54a66b9c..5dc63a29 100644 --- a/camlp4/ocaml_src/camlp4/mLast.mli +++ b/camlp4/ocaml_src/camlp4/mLast.mli @@ -19,7 +19,7 @@ these values in concrete syntax (see the Camlp4 documentation). See also the file q_MLast.ml in Camlp4 sources. *) -type loc = int * int;; +type loc = Lexing.position * Lexing.position;; type ctyp = TyAcc of loc * ctyp * ctyp @@ -104,6 +104,7 @@ and expr = | ExLmd of loc * string * module_expr * expr | ExMat of loc * expr * (patt * expr option * expr) list | ExNew of loc * string list + | ExObj of loc * patt option * class_str_item list | ExOlb of loc * string * expr option | ExOvr of loc * (string * expr) list | ExRec of loc * (patt * expr) list * expr option diff --git a/camlp4/ocaml_src/camlp4/pcaml.ml b/camlp4/ocaml_src/camlp4/pcaml.ml index 7258fa07..708e2e8f 100644 --- a/camlp4/ocaml_src/camlp4/pcaml.ml +++ b/camlp4/ocaml_src/camlp4/pcaml.ml @@ -20,7 +20,7 @@ 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_match = (fun _ -> raise (Match_failure ("", 23, 23))); Token.tok_text = (fun _ -> ""); Token.tok_comm = None} ;; @@ -58,7 +58,11 @@ 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 c1 = bp.Lexing.pos_cnum - bp.Lexing.pos_bol in + let c2 = ep.Lexing.pos_cnum - bp.Lexing.pos_bol in + Printf.eprintf " File \"%s\", line %d, chars %d-%d: %s\n" + bp.Lexing.pos_fname bp.Lexing.pos_lnum c1 c2 txt; + flush stderr ;; let warning = ref warning_default_function;; @@ -78,7 +82,7 @@ let quotation_dump_file = ref (None : string option);; type err_ctx = Finding | Expanding - | ParsingResult of (int * int) * string + | ParsingResult of MLast.loc * string | Locating ;; exception Qerror of string * err_ctx * exn;; @@ -86,14 +90,16 @@ 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 + fun (bp, ep) txt -> warn (Reloc.adjust_loc shift (bp, ep)) txt in apply_with_var warning new_warning (fun () -> try expander str with - Stdpp.Exc_located ((p1, p2), exc) -> + Stdpp.Exc_located (loc, exc) -> let exc1 = Qerror (name, Expanding, exc) in - raise (Stdpp.Exc_located ((shift + p1, shift + p2), exc1)) + raise + (Stdpp.Exc_located + (Reloc.adjust_loc shift (Reloc.linearize loc), exc1)) | exc -> let exc1 = Qerror (name, Expanding, exc) in raise (Stdpp.Exc_located (loc, exc1))) @@ -103,7 +109,7 @@ 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)) + raise (Stdpp.Exc_located (Reloc.adjust_loc shift iloc, exc)) | Stdpp.Exc_located (iloc, Qerror (_, Expanding, exc)) -> let ctx = ParsingResult (iloc, str) in let exc1 = Qerror (name, ctx, exc) in @@ -116,18 +122,22 @@ let parse_quotation_result entry loc shift name str = raise (Stdpp.Exc_located (loc, exc1)) ;; +let ghostify (bp, ep) = + let ghost p = {p with Lexing.pos_cnum = 0} in ghost bp, ghost ep +;; + 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 shift = Reloc.shift_pos shift (fst loc) 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)) + raise (Stdpp.Exc_located ((fst loc, shift), exc1)) in let ast = match expander with @@ -137,7 +147,13 @@ let handle_quotation loc proj in_expr entry reloc (name, str) = | Quotation.ExAst fe_fp -> expand_quotation loc (proj fe_fp) shift name str in - reloc (fun _ -> loc) shift ast + reloc + (let zero = ref None in + fun _ -> + match !zero with + None -> zero := Some (ghostify loc); loc + | Some x -> x) + shift ast ;; let parse_locate entry shift str = @@ -146,12 +162,12 @@ let parse_locate entry shift str = 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)) + raise (Stdpp.Exc_located (Reloc.adjust_loc shift (p1, p2), exc1)) ;; let handle_locate loc entry ast_f (pos, str) = let s = str in - let loc = pos, pos + String.length s in + let loc = pos, Reloc.shift_pos (String.length s) pos in let x = parse_locate entry (fst loc) s in ast_f loc x ;; @@ -165,13 +181,15 @@ Grammar.extend [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'expr) (loc : int * int) -> (x : 'expr_eoi))]]; + (fun _ (x : 'expr) (loc : Lexing.position * Lexing.position) -> + (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))]]];; + (fun _ (x : 'patt) (loc : Lexing.position * Lexing.position) -> + (x : 'patt_eoi))]]];; let handle_expr_quotation loc x = handle_quotation loc fst true expr_eoi Reloc.expr x @@ -188,16 +206,21 @@ 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 module_type_reloc = Reloc.module_type;; +let sig_item_reloc = Reloc.sig_item;; +let with_constr_reloc = Reloc.with_constr;; +let module_expr_reloc = Reloc.module_expr;; +let str_item_reloc = Reloc.str_item;; +let class_type_reloc = Reloc.class_type;; +let class_sig_item_reloc = Reloc.class_sig_item;; +let class_expr_reloc = Reloc.class_expr;; +let class_str_item_reloc = Reloc.class_str_item;; + let rename_id = ref (fun x -> x);; let find_line (bp, ep) str = - 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 + bp.Lexing.pos_lnum, bp.Lexing.pos_cnum - bp.Lexing.pos_bol, + ep.Lexing.pos_cnum - bp.Lexing.pos_bol ;; let loc_fmt = @@ -332,8 +355,7 @@ let report_error exn = | e -> print_exn exn ;; -let no_constructors_arity = Ast2pt.no_constructors_arity;; -(*value no_assert = ref False;*) +let no_constructors_arity = ref false;; let arg_spec_list_ref = ref [];; let arg_spec_list () = !arg_spec_list_ref;; @@ -360,48 +382,37 @@ and kont = pretty Stream.t ;; let pr_str_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 385, 30))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 406, 30))); pr_levels = []} ;; let pr_sig_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 386, 30))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 407, 30))); pr_levels = []} ;; let pr_module_type = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 387, 33))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 408, 33))); pr_levels = []} ;; let pr_module_expr = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 388, 33))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 409, 33))); pr_levels = []} ;; let pr_expr = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 389, 26))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 410, 26))); pr_levels = []} ;; let pr_patt = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 390, 26))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 411, 26))); pr_levels = []} ;; let pr_ctyp = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 391, 26))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 412, 26))); pr_levels = []} ;; let pr_class_sig_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 392, 36))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 413, 36))); pr_levels = []} ;; let pr_class_str_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 393, 36))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 414, 36))); pr_levels = []} ;; let pr_class_type = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 394, 32))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 415, 32))); pr_levels = []} ;; let pr_class_expr = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 395, 32))); - pr_levels = []} + {pr_fun = (fun _ -> raise (Match_failure ("", 416, 32))); pr_levels = []} ;; let pr_expr_fun_args = ref Extfun.empty;; diff --git a/camlp4/ocaml_src/camlp4/pcaml.mli b/camlp4/ocaml_src/camlp4/pcaml.mli index 8f8eacaf..fc6a315c 100644 --- a/camlp4/ocaml_src/camlp4/pcaml.mli +++ b/camlp4/ocaml_src/camlp4/pcaml.mli @@ -76,20 +76,47 @@ 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_expr_locate : MLast.loc -> Lexing.position * string -> MLast.expr;; val handle_patt_quotation : MLast.loc -> string * string -> MLast.patt;; -val handle_patt_locate : MLast.loc -> 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;; +val handle_patt_locate : MLast.loc -> Lexing.position * string -> MLast.patt;; + +(** Relocation functions for abstract syntax trees *) +val expr_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr;; +val patt_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt;; +val module_type_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type -> + MLast.module_type;; +val sig_item_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item -> + MLast.sig_item;; +val with_constr_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr -> + MLast.with_constr;; +val module_expr_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr -> + MLast.module_expr;; +val str_item_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item -> + MLast.str_item;; +val class_type_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type -> + MLast.class_type;; +val class_sig_item_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item -> + MLast.class_sig_item;; +val class_expr_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr -> + MLast.class_expr;; +val class_str_item_reloc : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item -> + MLast.class_str_item;; (** To possibly rename identifiers; parsers may call this function when generating their identifiers; default = identity *) @@ -99,7 +126,7 @@ val rename_id : (string -> string) ref;; type err_ctx = Finding | Expanding - | ParsingResult of (int * int) * string + | ParsingResult of MLast.loc * string | Locating ;; exception Qerror of string * err_ctx * exn;; @@ -152,7 +179,8 @@ val inter_phrases : string option ref;; (* for system use *) -val warning : (int * int -> string -> unit) ref;; +val warning : (MLast.loc -> 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;; +val no_constructors_arity : bool ref;; diff --git a/camlp4/ocaml_src/camlp4/reloc.ml b/camlp4/ocaml_src/camlp4/reloc.ml index 980d6ce7..1e22fee9 100644 --- a/camlp4/ocaml_src/camlp4/reloc.ml +++ b/camlp4/ocaml_src/camlp4/reloc.ml @@ -63,150 +63,268 @@ let class_infos a floc sh x = ciExp = a floc sh x.ciExp} ;; +(* Debugging positions and locations *) +let eprint_pos msg p = + Printf.eprintf "%s: fname=%s; lnum=%d; bol=%d; cnum=%d\n%!" msg + p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum +;; + +let eprint_loc (bp, ep) = eprint_pos " P1" bp; eprint_pos " P2" ep;; + +let check_position msg p = + let ok = + if p.Lexing.pos_lnum < 0 || p.Lexing.pos_bol < 0 || + p.Lexing.pos_cnum < 0 || p.Lexing.pos_cnum < p.Lexing.pos_bol + then + begin + Printf.eprintf "*** Warning: (%s) strange position ***\n" msg; + eprint_pos msg p; + false + end + else true + in + ok, p +;; + +let check_location msg (bp, ep as loc) = + let ok = + let (ok1, _) = check_position " From: " bp in + let (ok2, _) = check_position " To: " ep in + if not ok1 || not ok2 || bp.Lexing.pos_lnum > ep.Lexing.pos_lnum || + bp.Lexing.pos_bol > ep.Lexing.pos_bol || + bp.Lexing.pos_cnum > ep.Lexing.pos_cnum + then + begin + Printf.eprintf "*** Warning: (%s) strange location ***\n" msg; + eprint_loc loc; + false + end + else true + in + ok, loc +;; + +(* Change a location into linear positions *) +let linearize (bp, ep) = + {bp with Lexing.pos_lnum = 1; Lexing.pos_bol = 0}, + {ep with Lexing.pos_lnum = 1; Lexing.pos_bol = 0} +;; + +let shift_pos n p = {p with Lexing.pos_cnum = p.Lexing.pos_cnum + n};; + +let zero_loc = + {(Lexing.dummy_pos) with Lexing.pos_cnum = 0; Lexing.pos_lnum = 0} +;; + + +let adjust_pos globpos local_pos = + {Lexing.pos_fname = globpos.Lexing.pos_fname; + Lexing.pos_lnum = globpos.Lexing.pos_lnum + local_pos.Lexing.pos_lnum - 1; + Lexing.pos_bol = + if local_pos.Lexing.pos_lnum <= 1 then globpos.Lexing.pos_bol + else local_pos.Lexing.pos_bol + globpos.Lexing.pos_cnum; + Lexing.pos_cnum = local_pos.Lexing.pos_cnum + globpos.Lexing.pos_cnum} +;; + +let adjust_loc gpos (p1, p2) = adjust_pos gpos p1, adjust_pos gpos p2;; + +(* Note: in the following, the "let nloc = floc loc in" is necessary + in order to force evaluation order: the "floc" function has a side-effect + that changes all locations produced but the first one into ghost locations *) + 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) + PaAcc (loc, x1, x2) -> + let nloc = floc loc in PaAcc (nloc, self x1, self x2) + | PaAli (loc, x1, x2) -> + let nloc = floc loc in PaAli (nloc, 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) + patt + (fun lloc -> adjust_loc (adjust_pos sh (fst loc)) (linearize lloc)) + zero_loc x1 + | PaAny loc -> let nloc = floc loc in PaAny nloc + | PaApp (loc, x1, x2) -> + let nloc = floc loc in PaApp (nloc, self x1, self x2) + | PaArr (loc, x1) -> let nloc = floc loc in PaArr (nloc, List.map self x1) + | PaChr (loc, x1) -> let nloc = floc loc in PaChr (nloc, x1) + | PaInt (loc, x1) -> let nloc = floc loc in PaInt (nloc, x1) + | PaInt32 (loc, x1) -> let nloc = floc loc in PaInt32 (nloc, x1) + | PaInt64 (loc, x1) -> let nloc = floc loc in PaInt64 (nloc, x1) + | PaNativeInt (loc, x1) -> let nloc = floc loc in PaNativeInt (nloc, x1) + | PaFlo (loc, x1) -> let nloc = floc loc in PaFlo (nloc, x1) + | PaLab (loc, x1, x2) -> + let nloc = floc loc in PaLab (nloc, x1, option_map self x2) + | PaLid (loc, x1) -> let nloc = floc loc in PaLid (nloc, x1) | PaOlb (loc, x1, x2) -> + let nloc = floc loc in PaOlb - (floc loc, x1, + (nloc, 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) + | PaOrp (loc, x1, x2) -> + let nloc = floc loc in PaOrp (nloc, self x1, self x2) + | PaRng (loc, x1, x2) -> + let nloc = floc loc in PaRng (nloc, 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) + let nloc = floc loc in + PaRec (nloc, List.map (fun (x1, x2) -> self x1, self x2) x1) + | PaStr (loc, x1) -> let nloc = floc loc in PaStr (nloc, x1) + | PaTup (loc, x1) -> let nloc = floc loc in PaTup (nloc, List.map self x1) + | PaTyc (loc, x1, x2) -> + let nloc = floc loc in PaTyc (nloc, self x1, ctyp floc sh x2) + | PaTyp (loc, x1) -> let nloc = floc loc in PaTyp (nloc, x1) + | PaUid (loc, x1) -> let nloc = floc loc in PaUid (nloc, x1) + | PaVrn (loc, x1) -> let nloc = floc loc in PaVrn (nloc, x1) in self and expr floc sh = let rec self = function - ExAcc (loc, x1, x2) -> ExAcc (floc loc, self x1, self x2) + ExAcc (loc, x1, x2) -> + let nloc = floc loc in ExAcc (nloc, 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) + expr + (fun lloc -> adjust_loc (adjust_pos sh (fst loc)) (linearize lloc)) + zero_loc x1 + | ExApp (loc, x1, x2) -> + let nloc = floc loc in ExApp (nloc, self x1, self x2) + | ExAre (loc, x1, x2) -> + let nloc = floc loc in ExAre (nloc, self x1, self x2) + | ExArr (loc, x1) -> let nloc = floc loc in ExArr (nloc, List.map self x1) + | ExAsf loc -> let nloc = floc loc in ExAsf nloc + | ExAsr (loc, x1) -> let nloc = floc loc in ExAsr (nloc, self x1) + | ExAss (loc, x1, x2) -> + let nloc = floc loc in ExAss (nloc, self x1, self x2) + | ExChr (loc, x1) -> let nloc = floc loc in ExChr (nloc, 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) + let nloc = floc loc in + ExCoe (nloc, self x1, option_map (ctyp floc sh) x2, ctyp floc sh x3) + | ExFlo (loc, x1) -> let nloc = floc loc in ExFlo (nloc, x1) | ExFor (loc, x1, x2, x3, x4, x5) -> - ExFor (floc loc, x1, self x2, self x3, x4, List.map self x5) + let nloc = floc loc in + ExFor (nloc, x1, self x2, self x3, x4, List.map self x5) | ExFun (loc, x1) -> + let nloc = floc loc in ExFun - (floc loc, + (nloc, 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) + | ExIfe (loc, x1, x2, x3) -> + let nloc = floc loc in ExIfe (nloc, self x1, self x2, self x3) + | ExInt (loc, x1) -> let nloc = floc loc in ExInt (nloc, x1) + | ExInt32 (loc, x1) -> let nloc = floc loc in ExInt32 (nloc, x1) + | ExInt64 (loc, x1) -> let nloc = floc loc in ExInt64 (nloc, x1) + | ExNativeInt (loc, x1) -> let nloc = floc loc in ExNativeInt (nloc, x1) + | ExLab (loc, x1, x2) -> + let nloc = floc loc in ExLab (nloc, x1, option_map self x2) + | ExLaz (loc, x1) -> let nloc = floc loc in ExLaz (nloc, self x1) | ExLet (loc, x1, x2, x3) -> + let nloc = floc loc in 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) + (nloc, x1, List.map (fun (x1, x2) -> patt floc sh x1, self x2) x2, + self x3) + | ExLid (loc, x1) -> let nloc = floc loc in ExLid (nloc, x1) | ExLmd (loc, x1, x2, x3) -> - ExLmd (floc loc, x1, module_expr floc sh x2, self x3) + let nloc = floc loc in + ExLmd (nloc, x1, module_expr floc sh x2, self x3) | ExMat (loc, x1, x2) -> + let nloc = floc loc in ExMat - (floc loc, self x1, + (nloc, 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) + | ExNew (loc, x1) -> let nloc = floc loc in ExNew (nloc, x1) + | ExObj (loc, x1, x2) -> + let nloc = floc loc in + ExObj + (nloc, option_map (patt floc sh) x1, + List.map (class_str_item floc sh) x2) + | ExOlb (loc, x1, x2) -> + let nloc = floc loc in ExOlb (nloc, x1, option_map self x2) | ExOvr (loc, x1) -> - ExOvr (floc loc, List.map (fun (x1, x2) -> x1, self x2) x1) + let nloc = floc loc in + ExOvr (nloc, List.map (fun (x1, x2) -> x1, self x2) x1) | ExRec (loc, x1, x2) -> + let nloc = floc loc in ExRec - (floc loc, List.map (fun (x1, x2) -> patt floc sh x1, self x2) x1, + (nloc, 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) + | ExSeq (loc, x1) -> let nloc = floc loc in ExSeq (nloc, List.map self x1) + | ExSnd (loc, x1, x2) -> let nloc = floc loc in ExSnd (nloc, self x1, x2) + | ExSte (loc, x1, x2) -> + let nloc = floc loc in ExSte (nloc, self x1, self x2) + | ExStr (loc, x1) -> let nloc = floc loc in ExStr (nloc, x1) | ExTry (loc, x1, x2) -> + let nloc = floc loc in ExTry - (floc loc, self x1, + (nloc, 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) + | ExTup (loc, x1) -> let nloc = floc loc in ExTup (nloc, List.map self x1) + | ExTyc (loc, x1, x2) -> + let nloc = floc loc in ExTyc (nloc, self x1, ctyp floc sh x2) + | ExUid (loc, x1) -> let nloc = floc loc in ExUid (nloc, x1) + | ExVrn (loc, x1) -> let nloc = floc loc in ExVrn (nloc, x1) + | ExWhi (loc, x1, x2) -> + let nloc = floc loc in ExWhi (nloc, 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) + MtAcc (loc, x1, x2) -> + let nloc = floc loc in MtAcc (nloc, self x1, self x2) + | MtApp (loc, x1, x2) -> + let nloc = floc loc in MtApp (nloc, self x1, self x2) + | MtFun (loc, x1, x2, x3) -> + let nloc = floc loc in MtFun (nloc, x1, self x2, self x3) + | MtLid (loc, x1) -> let nloc = floc loc in MtLid (nloc, x1) + | MtQuo (loc, x1) -> let nloc = floc loc in MtQuo (nloc, x1) + | MtSig (loc, x1) -> + let nloc = floc loc in MtSig (nloc, List.map (sig_item floc sh) x1) + | MtUid (loc, x1) -> let nloc = floc loc in MtUid (nloc, x1) | MtWit (loc, x1, x2) -> - MtWit (floc loc, self x1, List.map (with_constr floc sh) x2) + let nloc = floc loc in + MtWit (nloc, 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) + let nloc = floc loc in + SgCls (nloc, 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) + let nloc = floc loc in + SgClt (nloc, List.map (class_infos class_type floc sh) x1) + | SgDcl (loc, x1) -> let nloc = floc loc in SgDcl (nloc, List.map self x1) + | SgDir (loc, x1, x2) -> let nloc = floc loc in SgDir (nloc, x1, x2) + | SgExc (loc, x1, x2) -> + let nloc = floc loc in SgExc (nloc, x1, List.map (ctyp floc sh) x2) + | SgExt (loc, x1, x2, x3) -> + let nloc = floc loc in SgExt (nloc, x1, ctyp floc sh x2, x3) + | SgInc (loc, x1) -> + let nloc = floc loc in SgInc (nloc, module_type floc sh x1) + | SgMod (loc, x1, x2) -> + let nloc = floc loc in SgMod (nloc, x1, module_type floc sh x2) | SgRecMod (loc, xxs) -> + let nloc = floc loc in 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) + (nloc, List.map (fun (x1, x2) -> x1, module_type floc sh x2) xxs) + | SgMty (loc, x1, x2) -> + let nloc = floc loc in SgMty (nloc, x1, module_type floc sh x2) + | SgOpn (loc, x1) -> let nloc = floc loc in SgOpn (nloc, x1) | SgTyp (loc, x1) -> + let nloc = floc loc in SgTyp - (floc loc, + (nloc, List.map (fun ((loc, x1), x2, x3, x4) -> (floc loc, x1), x2, ctyp floc sh x3, @@ -214,55 +332,72 @@ and sig_item floc sh = x4) x1) | SgUse (loc, x1, x2) -> SgUse (loc, x1, x2) - | SgVal (loc, x1, x2) -> SgVal (floc loc, x1, ctyp floc sh x2) + | SgVal (loc, x1, x2) -> + let nloc = floc loc in SgVal (nloc, 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) + WcTyp (loc, x1, x2, x3) -> + let nloc = floc loc in WcTyp (nloc, x1, x2, ctyp floc sh x3) + | WcMod (loc, x1, x2) -> + let nloc = floc loc in WcMod (nloc, 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) + MeAcc (loc, x1, x2) -> + let nloc = floc loc in MeAcc (nloc, self x1, self x2) + | MeApp (loc, x1, x2) -> + let nloc = floc loc in MeApp (nloc, 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) + let nloc = floc loc in + MeFun (nloc, x1, module_type floc sh x2, self x3) + | MeStr (loc, x1) -> + let nloc = floc loc in MeStr (nloc, List.map (str_item floc sh) x1) + | MeTyc (loc, x1, x2) -> + let nloc = floc loc in MeTyc (nloc, self x1, module_type floc sh x2) + | MeUid (loc, x1) -> let nloc = floc loc in MeUid (nloc, 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) + let nloc = floc loc in + StCls (nloc, 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) + let nloc = floc loc in + StClt (nloc, List.map (class_infos class_type floc sh) x1) + | StDcl (loc, x1) -> let nloc = floc loc in StDcl (nloc, List.map self x1) + | StDir (loc, x1, x2) -> let nloc = floc loc in StDir (nloc, 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) + let nloc = floc loc in + StExc (nloc, x1, List.map (ctyp floc sh) x2, x3) + | StExp (loc, x1) -> let nloc = floc loc in StExp (nloc, expr floc sh x1) + | StExt (loc, x1, x2, x3) -> + let nloc = floc loc in StExt (nloc, x1, ctyp floc sh x2, x3) + | StInc (loc, x1) -> + let nloc = floc loc in StInc (nloc, module_expr floc sh x1) + | StMod (loc, x1, x2) -> + let nloc = floc loc in StMod (nloc, x1, module_expr floc sh x2) | StRecMod (loc, nmtmes) -> + let nloc = floc loc in StRecMod - (floc loc, + (nloc, 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) + | StMty (loc, x1, x2) -> + let nloc = floc loc in StMty (nloc, x1, module_type floc sh x2) + | StOpn (loc, x1) -> let nloc = floc loc in StOpn (nloc, x1) | StTyp (loc, x1) -> + let nloc = floc loc in StTyp - (floc loc, + (nloc, List.map (fun ((loc, x1), x2, x3, x4) -> (floc loc, x1), x2, ctyp floc sh x3, @@ -271,19 +406,23 @@ and str_item floc sh = x1) | StUse (loc, x1, x2) -> StUse (loc, x1, x2) | StVal (loc, x1, x2) -> + let nloc = floc loc in StVal - (floc loc, x1, + (nloc, 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) + CtCon (loc, x1, x2) -> + let nloc = floc loc in CtCon (nloc, x1, List.map (ctyp floc sh) x2) + | CtFun (loc, x1, x2) -> + let nloc = floc loc in CtFun (nloc, ctyp floc sh x1, self x2) | CtSig (loc, x1, x2) -> + let nloc = floc loc in CtSig - (floc loc, option_map (ctyp floc sh) x1, + (nloc, option_map (ctyp floc sh) x1, List.map (class_sig_item floc sh) x2) in self @@ -291,47 +430,62 @@ 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) + let nloc = floc loc in CgCtr (nloc, 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) + let nloc = floc loc in + CgDcl (nloc, List.map (class_sig_item floc sh) x1) + | CgInh (loc, x1) -> + let nloc = floc loc in CgInh (nloc, class_type floc sh x1) + | CgMth (loc, x1, x2, x3) -> + let nloc = floc loc in CgMth (nloc, x1, x2, ctyp floc sh x3) + | CgVal (loc, x1, x2, x3) -> + let nloc = floc loc in CgVal (nloc, x1, x2, ctyp floc sh x3) + | CgVir (loc, x1, x2, x3) -> + let nloc = floc loc in CgVir (nloc, 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) + CeApp (loc, x1, x2) -> + let nloc = floc loc in CeApp (nloc, self x1, expr floc sh x2) + | CeCon (loc, x1, x2) -> + let nloc = floc loc in CeCon (nloc, x1, List.map (ctyp floc sh) x2) + | CeFun (loc, x1, x2) -> + let nloc = floc loc in CeFun (nloc, patt floc sh x1, self x2) | CeLet (loc, x1, x2, x3) -> + let nloc = floc loc in CeLet - (floc loc, x1, + (nloc, x1, List.map (fun (x1, x2) -> patt floc sh x1, expr floc sh x2) x2, self x3) | CeStr (loc, x1, x2) -> + let nloc = floc loc in CeStr - (floc loc, option_map (patt floc sh) x1, + (nloc, 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) + | CeTyc (loc, x1, x2) -> + let nloc = floc loc in CeTyc (nloc, 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) + let nloc = floc loc in CrCtr (nloc, 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) + let nloc = floc loc in + CrDcl (nloc, List.map (class_str_item floc sh) x1) + | CrInh (loc, x1, x2) -> + let nloc = floc loc in CrInh (nloc, class_expr floc sh x1, x2) + | CrIni (loc, x1) -> let nloc = floc loc in CrIni (nloc, 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) + let nloc = floc loc in + CrMth (nloc, x1, x2, expr floc sh x3, option_map (ctyp floc sh) x4) + | CrVal (loc, x1, x2, x3) -> + let nloc = floc loc in CrVal (nloc, x1, x2, expr floc sh x3) + | CrVir (loc, x1, x2, x3) -> + let nloc = floc loc in CrVir (nloc, x1, x2, ctyp floc sh x3) in self ;; diff --git a/camlp4/ocaml_src/camlp4/reloc.mli b/camlp4/ocaml_src/camlp4/reloc.mli index 21018b52..be5e93cd 100644 --- a/camlp4/ocaml_src/camlp4/reloc.mli +++ b/camlp4/ocaml_src/camlp4/reloc.mli @@ -12,5 +12,38 @@ (* 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;; +val zero_loc : Lexing.position;; +val shift_pos : int -> Lexing.position -> Lexing.position;; +val adjust_loc : Lexing.position -> MLast.loc -> MLast.loc;; +val linearize : MLast.loc -> MLast.loc;; +val patt : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt;; +val expr : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr;; +val module_type : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type -> + MLast.module_type;; +val sig_item : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item -> + MLast.sig_item;; +val with_constr : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr -> + MLast.with_constr;; +val module_expr : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr -> + MLast.module_expr;; +val str_item : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item -> + MLast.str_item;; +val class_type : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type -> + MLast.class_type;; +val class_sig_item : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item -> + MLast.class_sig_item;; +val class_expr : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr -> + MLast.class_expr;; +val class_str_item : + (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item -> + MLast.class_str_item;; diff --git a/camlp4/ocaml_src/lib/.depend b/camlp4/ocaml_src/lib/.depend index 0d5adc69..d7afaebe 100644 --- a/camlp4/ocaml_src/lib/.depend +++ b/camlp4/ocaml_src/lib/.depend @@ -2,6 +2,7 @@ extfold.cmi: gramext.cmi gramext.cmi: token.cmi grammar.cmi: gramext.cmi token.cmi plexer.cmi: token.cmi +stdpp.cmi: token.cmi extfold.cmo: gramext.cmi grammar.cmi extfold.cmi extfold.cmx: gramext.cmx grammar.cmx extfold.cmi extfun.cmo: extfun.cmi @@ -14,7 +15,7 @@ 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 +stdpp.cmo: token.cmi stdpp.cmi +stdpp.cmx: token.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 index e19e5205..722430e1 100644 --- a/camlp4/ocaml_src/lib/Makefile +++ b/camlp4/ocaml_src/lib/Makefile @@ -9,7 +9,10 @@ SHELL=/bin/sh TARGET=gramlib.cma all: $(TARGET) -opt: $(TARGET:.cma=.cmxa) +opt: opt$(PROFILING) + +optnoprof: $(TARGET:.cma=.cmxa) +optprof: optnoprof $(TARGET:.cma=.p.cmxa) $(TARGET): $(OBJS) $(OCAMLC) $(OBJS) -a -o $(TARGET) @@ -17,6 +20,9 @@ $(TARGET): $(OBJS) $(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx) $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa) +$(TARGET:.cma=.p.cmxa): $(OBJS:.cmo=.p.cmx) + $(OCAMLOPT) $(OBJS:.cmo=.p.cmx) -a -o $(TARGET:.cma=.p.cmxa) + clean:: rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET) @@ -39,10 +45,14 @@ install: -$(MKDIR) "$(LIBDIR)/camlp4" cp $(TARGET) *.mli "$(LIBDIR)/camlp4/." cp *.cmi "$(LIBDIR)/camlp4/." - if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi + test -f $(TARGET:.cma=.cmxa) && $(MAKE) installopt LIBDIR="$(LIBDIR)" || true installopt: - cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/." - tar cf - $(TARGET:.cma=.$(A)) | (cd "$(LIBDIR)/camlp4/."; tar xf -) + for f in $(TARGET:.cma=.cmxa) $(TARGET:.cma=.p.cmxa) ; do \ + test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true ; \ + done + # Special treatment for this one: some versions of make don't like $(A) in $(TARGET:.cma=.$(A)) + target="`echo $(TARGET) | sed -e 's/\.cma$$/.$(A))/'`" ; \ + test -f $$target && cp $$target "$(LIBDIR)/camlp4/." || true include .depend diff --git a/camlp4/ocaml_src/lib/Makefile.Mac b/camlp4/ocaml_src/lib/Makefile.Mac deleted file mode 100644 index 2fc15c63..00000000 --- a/camlp4/ocaml_src/lib/Makefile.Mac +++ /dev/null @@ -1,46 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -OCAMLCFLAGS = {INCLUDES} -OBJS = stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfun.cmo fstream.cmo -INTF = stdpp.cmi token.cmi plexer.cmi gramext.cmi grammar.cmi extfun.cmi fstream.cmi -TARGETS = gramlib.cma - -all Ä {TARGETS} - -{TARGETS} Ä {OBJS} - {OCAMLC} {OBJS} -a -o {TARGETS} - -steal Ä - -compare_stolen Ä - -clean ÄÄ - delete -i {TARGETS} - -{dependrule} - -promote Ä - duplicate -y {OBJS} {INTF} :::boot: - -compare Ä - for i in {OBJS} {INTF} - equal -s :::boot:{i} || exit 1 - end - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - duplicate -y {TARGETS} Å.mli Å.cmi "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/ocaml_src/lib/Makefile.Mac.depend b/camlp4/ocaml_src/lib/Makefile.Mac.depend deleted file mode 100644 index 8d12e3e0..00000000 --- a/camlp4/ocaml_src/lib/Makefile.Mac.depend +++ /dev/null @@ -1,13 +0,0 @@ -gramext.cmoÄ token.cmi gramext.cmi -gramext.cmxÄ token.cmx gramext.cmi -gramext.cmiÄ token.cmi -grammar.cmoÄ gramext.cmi stdpp.cmi token.cmi grammar.cmi -grammar.cmxÄ gramext.cmx stdpp.cmx token.cmx grammar.cmi -grammar.cmiÄ gramext.cmi token.cmi -plexer.cmoÄ stdpp.cmi token.cmi plexer.cmi -plexer.cmxÄ stdpp.cmx token.cmx plexer.cmi -plexer.cmiÄ token.cmi -stdpp.cmoÄ stdpp.cmi -stdpp.cmxÄ stdpp.cmi -token.cmoÄ token.cmi -token.cmxÄ token.cmi diff --git a/camlp4/ocaml_src/lib/grammar.ml b/camlp4/ocaml_src/lib/grammar.ml index 196a6b95..3501976d 100644 --- a/camlp4/ocaml_src/lib/grammar.ml +++ b/camlp4/ocaml_src/lib/grammar.ml @@ -194,11 +194,13 @@ 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 + if bp == 0 then Token.nowhere, Token.succ_pos Token.nowhere + else let a = snd (!floc (bp - 1)) in a, Token.succ_pos a 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) + (if Token.lt_pos bp1 ep1 then bp1 else ep1), + (if Token.lt_pos ep2 bp2 then bp2 else ep2) ;; let rec name_of_symbol entry = @@ -805,7 +807,7 @@ let parse_parsable entry efun (cs, (ts, fun_loc)) = if !token_count - 1 <= cnt then loc else fst loc, snd (fun_loc (!token_count - 1)) with - _ -> Stream.count cs, Stream.count cs + 1 + _ -> Token.nowhere, Token.succ_pos Token.nowhere in floc := fun_loc; token_count := 0; @@ -817,7 +819,7 @@ let parse_parsable entry efun (cs, (ts, fun_loc)) = | 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 + let loc = Token.nowhere, Token.succ_pos Token.nowhere in restore (); raise_with_loc loc exc ;; @@ -1060,7 +1062,7 @@ 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);; + type parsable = char Stream.t * (te Stream.t * Token.flocation_function);; let gram = gcreate L.lexer;; let parsable cs = cs, L.lexer.Token.tok_func cs;; let tokens = tokens gram;; diff --git a/camlp4/ocaml_src/lib/grammar.mli b/camlp4/ocaml_src/lib/grammar.mli index d38b449f..34dee1b3 100644 --- a/camlp4/ocaml_src/lib/grammar.mli +++ b/camlp4/ocaml_src/lib/grammar.mli @@ -183,7 +183,7 @@ val create : Token.lexer -> g;; (*** For system use *) -val loc_of_token_interval : int -> int -> int * int;; +val loc_of_token_interval : int -> int -> Token.flocation;; val extend : ('te Gramext.g_entry * Gramext.position option * (string option * Gramext.g_assoc option * diff --git a/camlp4/ocaml_src/lib/plexer.ml b/camlp4/ocaml_src/lib/plexer.ml index 329e0b77..e1044808 100644 --- a/camlp4/ocaml_src/lib/plexer.ml +++ b/camlp4/ocaml_src/lib/plexer.ml @@ -92,6 +92,9 @@ and digits_under kind len (strm__ : _ Stream.t) = | _ -> match Stream.peek strm__ with Some '_' -> Stream.junk strm__; digits_under kind len 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 octal (strm__ : _ Stream.t) = match Stream.peek strm__ with @@ -145,371 +148,85 @@ and end_exponent_part_under len (strm__ : _ Stream.t) = 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 - | [: :] -> () ] +(* Debugging positions and locations *) +let eprint_pos msg p = + Printf.eprintf "%s: fname=%s; lnum=%d; bol=%d; cnum=%d\n%!" msg + p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum +;; + +let eprint_loc (bp, ep) = eprint_pos "P1" bp; eprint_pos "P2" ep;; + +let check_location msg (bp, ep as loc) = + let ok = + if bp.Lexing.pos_lnum > ep.Lexing.pos_lnum || + bp.Lexing.pos_bol > ep.Lexing.pos_bol || + bp.Lexing.pos_cnum > ep.Lexing.pos_cnum || bp.Lexing.pos_lnum < 0 || + ep.Lexing.pos_lnum < 0 || bp.Lexing.pos_bol < 0 || + ep.Lexing.pos_bol < 0 || bp.Lexing.pos_cnum < 0 || + ep.Lexing.pos_cnum < 0 + then + begin + Printf.eprintf "*** Warning: (%s) strange positions ***\n" msg; + eprint_loc loc; + false + end + else true 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 ] -; -*) + ok, loc +;; -let next_token_fun dfa ssd find_kwd bolpos glexr = - let keyword_or_error loc s = +let next_token_fun dfa ssd find_kwd fname lnum bolpos glexr = + let make_pos p = + {Lexing.pos_fname = !fname; Lexing.pos_lnum = !lnum; + Lexing.pos_bol = !bolpos; Lexing.pos_cnum = p} + in + let mkloc (bp, ep) = make_pos bp, make_pos ep in + let keyword_or_error (bp, ep) s = + let loc = mkloc (bp, ep) in try ("", find_kwd s), loc with Not_found -> if !error_on_unknown_keywords then err loc ("illegal token: " ^ s) else ("", s), loc in - let error_if_keyword ((_, id), loc as a) = + let error_if_keyword ((_, id as a), bep) = + let loc = mkloc bep in try ignore (find_kwd id); err loc ("illegal use of a keyword as a label: " ^ id) with - Not_found -> a + Not_found -> a, 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') -> + Some '\010' -> Stream.junk strm__; let s = strm__ in - let ep = Stream.count strm__ in bolpos := ep; next_token true s + let ep = Stream.count strm__ in + bolpos := ep; incr lnum; next_token true s + | Some '\013' -> + Stream.junk strm__; + let s = strm__ in + let ep = Stream.count strm__ in + let ep = + match Stream.peek s with + Some '\010' -> Stream.junk s; ep + 1 + | _ -> ep + in + bolpos := ep; incr lnum; 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 + if linedir 1 s then begin line_directive 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 + let loc = mkloc (bp, Stream.count s) in (try "", find_kwd id with Not_found -> "UIDENT", id), loc @@ -517,35 +234,35 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = Stream.junk strm__; let s = strm__ in let id = get_buff (ident (store 0 c) s) in - let loc = bp, Stream.count s in + let loc = mkloc (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 + let loc = mkloc (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 + let loc = mkloc (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 + let loc = mkloc (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 + let loc = mkloc (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 + let loc = mkloc (bp, Stream.count strm__) in tok, loc | Some ('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c) -> Stream.junk strm__; let id = get_buff (ident2 (store 0 c) strm__) in @@ -671,12 +388,12 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = | Some '\\' -> Stream.junk strm__; let ep = Stream.count strm__ in - ("LIDENT", get_buff (ident3 0 strm__)), (bp, ep) + ("LIDENT", get_buff (ident3 0 strm__)), mkloc (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) + | _ -> let _ = Stream.empty strm__ in ("EOI", ""), mkloc (bp, succ bp) and less bp strm = if !no_quotations then let (strm__ : _ Stream.t) = strm in @@ -693,7 +410,7 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = Stream.Failure -> raise (Stream.Error "") in let ep = Stream.count strm__ in - ("QUOTATION", ":" ^ get_buff len), (bp, ep) + ("QUOTATION", ":" ^ get_buff len), mkloc (bp, ep) | Some ':' -> Stream.junk strm__; let i = @@ -708,7 +425,7 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = Stream.Failure -> raise (Stream.Error "") in let ep = Stream.count strm__ in - ("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep) + ("QUOTATION", i ^ ":" ^ get_buff len), mkloc (bp, ep) | _ -> raise (Stream.Error "character '<' expected") end | _ -> @@ -722,12 +439,31 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = Stream.junk strm__; begin match Stream.peek strm__ with Some c -> - Stream.junk strm__; string bp (store (store len '\\') c) strm__ + Stream.junk strm__; + let ep = Stream.count strm__ in + string bp (store (store len '\\') c) strm__ | _ -> raise (Stream.Error "") end + | Some '\010' -> + Stream.junk strm__; + let s = strm__ in + let ep = Stream.count strm__ in + bolpos := ep; incr lnum; string bp len s + | Some '\013' -> + Stream.junk strm__; + let s = strm__ in + let ep = Stream.count strm__ in + let (len, ep) = + match Stream.peek s with + Some '\010' -> + Stream.junk s; store (store len '\013') '\010', ep + 1 + | _ -> store len '\013', ep + in + bolpos := ep; incr lnum; string bp len s | Some c -> Stream.junk strm__; string bp (store len c) strm__ | _ -> - let ep = Stream.count strm__ in err (bp, ep) "string not terminated" + let ep = Stream.count strm__ in + err (mkloc (bp, ep)) "string not terminated" and char bp len (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '\'' -> @@ -740,8 +476,23 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = Stream.junk strm__; char bp (store (store len '\\') c) strm__ | _ -> raise (Stream.Error "") end + | Some '\010' -> + Stream.junk strm__; + let s = strm__ in + bolpos := bp + 1; incr lnum; char bp (store len '\010') s + | Some '\013' -> + Stream.junk strm__; + let s = strm__ in + let bol = + match Stream.peek s with + Some '\010' -> Stream.junk s; bp + 2 + | _ -> bp + 1 + in + bolpos := bol; incr lnum; char bp (store len '\013') s | Some c -> Stream.junk strm__; char bp (store len c) strm__ - | _ -> let ep = Stream.count strm__ in err (bp, ep) "char not terminated" + | _ -> + let ep = Stream.count strm__ in + err (mkloc (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 @@ -771,7 +522,7 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s | _ -> let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" + err (mkloc (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 @@ -794,7 +545,7 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ | _ -> let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" + err (mkloc (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 @@ -817,7 +568,7 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ | _ -> let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" + err (mkloc (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 @@ -833,7 +584,7 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = Stream.junk strm__; locate_or_antiquot_rest bp (store len c) strm__ | _ -> let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" + err (mkloc (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__ @@ -851,10 +602,23 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = Stream.Failure -> raise (Stream.Error "") in quotation bp len strm__ + | Some '\010' -> + Stream.junk strm__; + let s = strm__ in + bolpos := bp + 1; incr lnum; quotation bp (store len '\010') s + | Some '\013' -> + Stream.junk strm__; + let s = strm__ in + let bol = + match Stream.peek s with + Some '\010' -> Stream.junk s; bp + 2 + | _ -> bp + 1 + in + bolpos := bol; incr lnum; quotation bp (store len '\013') s | Some c -> Stream.junk strm__; quotation bp (store len c) strm__ | _ -> let ep = Stream.count strm__ in - err (bp, ep) "quotation not terminated" + err (mkloc (bp, ep)) "quotation not terminated" and maybe_nested_quotation bp len (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '<' -> @@ -903,9 +667,24 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = in comment bp strm__ | Some '\'' -> Stream.junk strm__; quote_in_comment bp strm__ + | Some '\010' -> + Stream.junk strm__; + let s = strm__ in + let ep = Stream.count strm__ in bolpos := ep; incr lnum; comment bp s + | Some '\013' -> + Stream.junk strm__; + let s = strm__ in + let ep = Stream.count strm__ in + let ep = + match Stream.peek s with + Some '\010' -> Stream.junk s; ep + 1 + | _ -> ep + in + bolpos := ep; incr lnum; comment bp s | Some c -> Stream.junk strm__; comment bp strm__ | _ -> - let ep = Stream.count strm__ in err (bp, ep) "comment not terminated" + let ep = Stream.count strm__ in + err (mkloc (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__ @@ -913,7 +692,19 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = | _ -> let s = strm__ in begin match Stream.npeek 2 s with - [_; '\''] -> Stream.junk s; Stream.junk s + ['\013' | '\010'; '\''] -> + bolpos := bp + 1; incr lnum; Stream.junk s; Stream.junk s + | ['\013'; '\010'] -> + begin match Stream.npeek 3 s with + [_; _; '\''] -> + bolpos := bp + 2; + incr lnum; + Stream.junk s; + Stream.junk s; + Stream.junk s + | _ -> () + end + | [_; '\''] -> Stream.junk s; Stream.junk s | _ -> () end; comment bp s @@ -950,23 +741,73 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = 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 + | Some ('0'..'9') -> 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 '\010' -> + Stream.junk strm__; + let s = strm__ in + let ep = Stream.count strm__ in bolpos := ep; incr lnum + | Some '\013' -> + Stream.junk strm__; + let s = strm__ in + let ep = Stream.count strm__ in + let ep = + match Stream.peek s with + Some '\010' -> Stream.junk s; ep + 1 + | _ -> ep + in + bolpos := ep; incr lnum | Some _ -> Stream.junk strm__; any_to_nl strm__ | _ -> () + and line_directive (strm__ : _ Stream.t) = + let _ = skip_spaces strm__ in + let n = + try line_directive_number 0 strm__ with + Stream.Failure -> raise (Stream.Error "") + in + let _ = + try skip_spaces strm__ with + Stream.Failure -> raise (Stream.Error "") + in + let _ = + try line_directive_string strm__ with + Stream.Failure -> raise (Stream.Error "") + in + let _ = + try any_to_nl strm__ with + Stream.Failure -> raise (Stream.Error "") + in + let ep = Stream.count strm__ in bolpos := ep; lnum := n + and skip_spaces (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some (' ' | '\t') -> Stream.junk strm__; skip_spaces strm__ + | _ -> () + and line_directive_number n (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some ('0'..'9' as c) -> + Stream.junk strm__; + line_directive_number (10 * n + (Char.code c - Char.code '0')) strm__ + | _ -> n + and line_directive_string (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some '\"' -> + Stream.junk strm__; + let _ = + try line_directive_string_contents 0 strm__ with + Stream.Failure -> raise (Stream.Error "") + in + () + | _ -> () + and line_directive_string_contents len (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some ('\010' | '\013') -> Stream.junk strm__; () + | Some '\"' -> Stream.junk strm__; fname := get_buff len + | Some c -> + Stream.junk strm__; + line_directive_string_contents (store len c) strm__ + | _ -> raise Stream.Failure in fun cstrm -> try @@ -975,14 +816,16 @@ let next_token_fun dfa ssd find_kwd bolpos glexr = 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 + let next_bp = (fst (snd r)).Lexing.pos_cnum in + if next_bp > comm_bp then + let comm_loc = mkloc (comm_bp, next_bp) in glex.tok_comm <- Some (comm_loc :: list) | None -> () end; r with - Stream.Error str -> err (Stream.count cstrm, Stream.count cstrm + 1) str + Stream.Error str -> + err (mkloc (Stream.count cstrm, Stream.count cstrm + 1)) str ;; @@ -991,10 +834,13 @@ let specific_space_dot = ref false;; let func kwd_table glexr = let bolpos = ref 0 in + let lnum = ref 1 in + let fname = ref "" 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) + Token.lexer_func_of_parser + (next_token_fun dfa ssd find fname lnum bolpos glexr) ;; let rec check_keyword_stream (strm__ : _ Stream.t) = @@ -1209,11 +1055,11 @@ let gmake () = let id_table = Hashtbl.create 301 in let glexr = ref - {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 972, 17))); - tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 972, 37))); - tok_removing = (fun _ -> raise (Match_failure ("plexer.ml", 972, 60))); - tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 973, 18))); - tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 973, 37))); + {tok_func = (fun _ -> raise (Match_failure ("", 748, 17))); + tok_using = (fun _ -> raise (Match_failure ("", 748, 37))); + tok_removing = (fun _ -> raise (Match_failure ("", 748, 60))); + tok_match = (fun _ -> raise (Match_failure ("", 749, 18))); + tok_text = (fun _ -> raise (Match_failure ("", 749, 37))); tok_comm = None} in let glex = @@ -1243,12 +1089,11 @@ let make () = let id_table = Hashtbl.create 301 in let glexr = ref - {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 1001, 17))); - tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 1001, 37))); - tok_removing = - (fun _ -> raise (Match_failure ("plexer.ml", 1001, 60))); - tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 1002, 18))); - tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 1002, 37))); + {tok_func = (fun _ -> raise (Match_failure ("", 777, 17))); + tok_using = (fun _ -> raise (Match_failure ("", 777, 37))); + tok_removing = (fun _ -> raise (Match_failure ("", 777, 60))); + tok_match = (fun _ -> raise (Match_failure ("", 778, 18))); + tok_text = (fun _ -> raise (Match_failure ("", 778, 37))); tok_comm = None} in {func = func kwd_table glexr; using = using_token kwd_table id_table; diff --git a/camlp4/ocaml_src/lib/stdpp.ml b/camlp4/ocaml_src/lib/stdpp.ml index d91ee78c..ab80b24a 100644 --- a/camlp4/ocaml_src/lib/stdpp.ml +++ b/camlp4/ocaml_src/lib/stdpp.ml @@ -12,7 +12,7 @@ (* This file has been generated by program: do not edit! *) -exception Exc_located of (int * int) * exn;; +exception Exc_located of Token.flocation * exn;; let raise_with_loc loc exc = match exc with @@ -21,79 +21,67 @@ let raise_with_loc loc exc = ;; let line_of_loc fname (bp, ep) = + bp.Lexing.pos_fname, bp.Lexing.pos_lnum, + bp.Lexing.pos_cnum - bp.Lexing.pos_bol, + ep.Lexing.pos_cnum - bp.Lexing.pos_bol +;; + +(* +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 (strm__ : _ Stream.t) = - let cnt = Stream.count strm__ in - match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - let s = strm__ in + 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 - | _ -> raise Stream.Failure + else + let col = col - (cnt - bp) in + (fname, lin, col, col + ep - bp) 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 + 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 (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ' ' -> Stream.junk strm__; spaces (col + 1) strm__ - | _ -> col + let rec spaces col = + parser + [ [: `' '; s :] -> spaces (col + 1) s + | [: :] -> 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__ + 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 (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\"' -> Stream.junk strm__; check_string "" n (col + 1) strm__ - | _ -> not_a_line_dir col strm__ + 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 (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__ + 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 (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__ + 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 - close_in ic; r + 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 -;; + [ 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 index 68c0cb6a..e966ee9a 100644 --- a/camlp4/ocaml_src/lib/stdpp.mli +++ b/camlp4/ocaml_src/lib/stdpp.mli @@ -14,18 +14,18 @@ (** Standard definitions. *) -exception Exc_located of (int * int) * exn;; +exception Exc_located of Token.flocation * 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;; +val raise_with_loc : Token.flocation -> 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;; +val line_of_loc : string -> Token.flocation -> 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 diff --git a/camlp4/ocaml_src/lib/token.ml b/camlp4/ocaml_src/lib/token.ml index 67aaffde..d2ddeded 100644 --- a/camlp4/ocaml_src/lib/token.ml +++ b/camlp4/ocaml_src/lib/token.ml @@ -17,9 +17,22 @@ 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;; +let make_loc (bp, ep) = + {(Lexing.dummy_pos) with Lexing.pos_cnum = bp; Lexing.pos_lnum = 1}, + {(Lexing.dummy_pos) with Lexing.pos_cnum = ep; Lexing.pos_lnum = 1} +;; + +let nowhere = {(Lexing.dummy_pos) with Lexing.pos_cnum = 0};; + +let dummy_loc = Lexing.dummy_pos, Lexing.dummy_pos;; + +let succ_pos p = {p with Lexing.pos_cnum = p.Lexing.pos_cnum + 1};; +let lt_pos p1 p2 = p1.Lexing.pos_cnum < p2.Lexing.pos_cnum;; + +type flocation = Lexing.position * Lexing.position;; + +type flocation_function = int -> flocation;; +type 'te lexer_func = char Stream.t -> 'te Stream.t * flocation_function;; type 'te glexer = { tok_func : 'te lexer_func; @@ -27,7 +40,7 @@ type 'te glexer = tok_removing : pattern -> unit; tok_match : pattern -> 'te -> string; tok_text : pattern -> string; - mutable tok_comm : location list option } + mutable tok_comm : flocation list option } ;; type lexer = { func : t lexer_func; @@ -43,29 +56,39 @@ let lexer_text (con, prm) = else con ^ " '" ^ prm ^ "'" ;; -let locerr () = invalid_arg "Lexer: location function";; -let loct_create () = ref (Array.create 1024 None), ref false;; +let locerr () = invalid_arg "Lexer: flocation function";; + +let tsz = 256;; (* up to 2^29 entries on a 32-bit machine, 2^61 on 64-bit *) + +let loct_create () = ref [| |], 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 + if i < 0 || i / tsz >= Array.length !loct then None + else if !loct.(i / tsz) = [| |] then + if !ov then Some (nowhere, nowhere) else None + else Array.unsafe_get (Array.unsafe_get !loct (i / tsz)) (i mod tsz) 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 + while i / tsz >= Array.length !loct && not !ov do + let new_tmax = Array.length !loct * 2 + 1 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 + let new_loct = Array.make new_tmax [| |] in + Array.blit !loct 0 new_loct 0 (Array.length !loct); loct := new_loct else ov := true - else !loct.(i) <- Some loc + done; + if not !ov then + begin + if !loct.(i / tsz) = [| |] then !loct.(i / tsz) <- Array.make tsz None; + !loct.(i / tsz).(i mod tsz) <- Some loc + end ;; -let make_stream_and_location next_token_loc = +let make_stream_and_flocation next_token_loc = let loct = loct_create () in let ts = Stream.from @@ -76,7 +99,7 @@ let make_stream_and_location next_token_loc = ;; let lexer_func_of_parser next_token_loc cs = - make_stream_and_location (fun () -> next_token_loc cs) + make_stream_and_flocation (fun () -> next_token_loc cs) ;; let lexer_func_of_ocamllex lexfun cs = @@ -88,9 +111,9 @@ let lexer_func_of_ocamllex lexfun cs = in let next_token_loc _ = let tok = lexfun lb in - let loc = Lexing.lexeme_start lb, Lexing.lexeme_end lb in tok, loc + let loc = Lexing.lexeme_start_p lb, Lexing.lexeme_end_p lb in tok, loc in - make_stream_and_location next_token_loc + make_stream_and_flocation next_token_loc ;; (* Char and string tokens to real chars and string *) @@ -129,25 +152,25 @@ let rec backslash s i = | 'x' -> backslash1h s (i + 1) | _ -> raise Not_found and backslash1 cod s i = - if i = String.length s then '\\', i - 1 + if i = String.length s then raise Not_found else match s.[i] with '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> '\\', i - 1 + | _ -> raise Not_found and backslash2 cod s i = - if i = String.length s then '\\', i - 2 + if i = String.length s then raise Not_found else match s.[i] with '0'..'9' as c -> Char.chr (10 * cod + valch c), i + 1 - | _ -> '\\', i - 2 + | _ -> raise Not_found and backslash1h s i = - if i = String.length s then '\\', i - 1 + if i = String.length s then raise Not_found else match s.[i] with '0'..'9' as c -> backslash2h (valch c) s (i + 1) | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1) | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1) - | _ -> '\\', i - 1 + | _ -> raise Not_found and backslash2h cod s i = if i = String.length s then '\\', i - 2 else @@ -155,7 +178,7 @@ and backslash2h cod s i = '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 + | _ -> raise Not_found ;; let rec skip_indent s i = @@ -184,7 +207,7 @@ let eval_char s = else failwith "invalid char token" ;; -let eval_string s = +let eval_string (bp, ep) s = let rec loop len i = if i = String.length s then get_buff len else @@ -199,7 +222,18 @@ let eval_string s = | '\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 + Not_found -> + let txt = "Invalid backslash escape in string" in + let pos = bp.Lexing.pos_cnum - bp.Lexing.pos_bol + i in + if bp.Lexing.pos_fname = "" then + Printf.eprintf "Warning: line %d, chars %d-%d: %s\n" + bp.Lexing.pos_lnum pos (pos + 1) txt + else + Printf.eprintf + "Warning: File \"%s\", line %d, chars %d-%d: %s\n" + bp.Lexing.pos_fname bp.Lexing.pos_lnum pos (pos + 1) + txt; + store (store len '\\') c, i + 1 else store len s.[i], i + 1 in loop len i diff --git a/camlp4/ocaml_src/lib/token.mli b/camlp4/ocaml_src/lib/token.mli index e561e28e..715170bd 100644 --- a/camlp4/ocaml_src/lib/token.mli +++ b/camlp4/ocaml_src/lib/token.mli @@ -33,11 +33,19 @@ exception Error of string;; (** {6 Lexer type} *) -type location = int * int;; -type location_function = int -> location;; +type flocation = Lexing.position * Lexing.position;; + +val nowhere : Lexing.position;; +val dummy_loc : flocation;; + +val make_loc : int * int -> flocation;; +val succ_pos : Lexing.position -> Lexing.position;; +val lt_pos : Lexing.position -> Lexing.position -> bool;; + +type flocation_function = int -> flocation;; (** 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;; +type 'te lexer_func = char Stream.t -> 'te Stream.t * flocation_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. *) @@ -48,7 +56,7 @@ type 'te glexer = tok_removing : pattern -> unit; tok_match : pattern -> 'te -> string; tok_text : pattern -> string; - mutable tok_comm : location list option } + mutable tok_comm : flocation list option } ;; (** The type for a lexer used by Camlp4 grammars. - The field [tok_func] is the main lexer function. See [lexer_func] @@ -96,24 +104,29 @@ val default_match : pattern -> string * string -> string;; as well. *) val lexer_func_of_parser : - (char Stream.t -> 'te * location) -> 'te lexer_func;; + (char Stream.t -> 'te * flocation) -> '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;; +val make_stream_and_flocation : + (unit -> 'te * flocation) -> 'te Stream.t * flocation_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] *) + (** Convert a char token, where the escape sequences (backslashes) + remain to be interpreted; raise [Failure] if an + incorrect backslash sequence is found; [Token.eval_char (Char.escaped c)] + returns [c] *) + +val eval_string : flocation -> string -> string;; + (** Convert a string token, where the escape sequences (backslashes) + remain to be interpreted; issue a warning if an incorrect + backslash sequence is found; + [Token.eval_string loc (String.escaped s)] returns [s] *) (**/**) diff --git a/camlp4/ocaml_src/meta/.depend b/camlp4/ocaml_src/meta/.depend index 737ea5ec..977947f5 100644 --- a/camlp4/ocaml_src/meta/.depend +++ b/camlp4/ocaml_src/meta/.depend @@ -1,9 +1,7 @@ -pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx +pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/reloc.cmi +pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/reloc.cmx pa_extend_m.cmo: pa_extend.cmo pa_extend_m.cmx: pa_extend.cmx -pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi @@ -12,5 +10,7 @@ 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 +q_MLast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi \ + ../camlp4/reloc.cmi +q_MLast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx \ + ../camlp4/reloc.cmx diff --git a/camlp4/ocaml_src/meta/Makefile b/camlp4/ocaml_src/meta/Makefile index 3996cd2c..d0b3cd51 100644 --- a/camlp4/ocaml_src/meta/Makefile +++ b/camlp4/ocaml_src/meta/Makefile @@ -10,7 +10,7 @@ CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx) SHELL=/bin/sh COUT=$(OBJS) camlp4r$(EXE) -COPT=camlp4r.opt +COPT=$(OBJSX) camlp4r.opt all: $(COUT) opt: $(COPT) @@ -49,11 +49,7 @@ install: cp camlp4r$(EXE) "$(BINDIR)/." if test -f camlp4r.opt; then \ cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\ - for target in $(OBJSX) $(OBJSX:.cmx=.$(O)) ; do \ - if test -f $$target; then \ - cp $$target "$(LIBDIR)/camlp4/."; \ - fi; \ - done; \ + cp $(OBJSX) $(OBJSX:.cmx=.$(O)) "$(LIBDIR)/camlp4/."; \ fi include .depend diff --git a/camlp4/ocaml_src/meta/Makefile.Mac b/camlp4/ocaml_src/meta/Makefile.Mac deleted file mode 100644 index b62b945c..00000000 --- a/camlp4/ocaml_src/meta/Makefile.Mac +++ /dev/null @@ -1,50 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -I ::camlp4: -I :::boot: -I "{OTOP}utils:" -OCAMLCFLAGS = {INCLUDES} -OBJS = q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo ¶ - pa_ifdef.cmo pr_dump.cmo -CAMLP4RM = pa_r.cmo pa_rp.cmo pr_dump.cmo -OUT = {OBJS} camlp4r - -all Ä {OUT} - -camlp4r Ä ::camlp4:camlp4 {CAMLP4RM} - delete -i camlp4r - directory ::camlp4: - domake -d CAMLP4=::meta:camlp4r -d CAMLP4M="-I ::meta {CAMLP4RM}" - directory ::meta: - -clean ÄÄ - delete -i {OUT} - -{dependrule} - -promote Ä - duplicate -y {OUT} pa_extend.cmi :::boot: - -compare Ä - for i in {OUT} - equal -s {i} :::boot:{i} || exit 1 - end - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {OBJS} "{P4LIBDIR}" - duplicate -y camlp4r "{BINDIR}" - -{defrules} - -pr_dump.cmo Ä ::camlp4:ast2pt.cmo "{OTOP}utils:config.cmi" ::camlp4:pcaml.cmi diff --git a/camlp4/ocaml_src/meta/Makefile.Mac.depend b/camlp4/ocaml_src/meta/Makefile.Mac.depend deleted file mode 100644 index 29675238..00000000 --- a/camlp4/ocaml_src/meta/Makefile.Mac.depend +++ /dev/null @@ -1,12 +0,0 @@ -pa_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_extend_m.cmoÄ ::camlp4:mLast.cmi pa_extend.cmo -pa_extend_m.cmxÄ ::camlp4:mLast.cmi pa_extend.cmx -pa_macro.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_macro.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -q_MLast.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi -q_MLast.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx diff --git a/camlp4/ocaml_src/meta/pa_extend.ml b/camlp4/ocaml_src/meta/pa_extend.ml index d68baf8d..2258b962 100644 --- a/camlp4/ocaml_src/meta/pa_extend.ml +++ b/camlp4/ocaml_src/meta/pa_extend.ml @@ -22,9 +22,9 @@ Pcaml.add_option "-split_ext" (Arg.Set split_ext) Pcaml.add_option "-split_gext" (Arg.Set split_ext) "Old name for the option -split_ext.";; -type loc = int * int;; +type loc = Lexing.position * Lexing.position;; -type 'e name = { expr : 'e; tvar : string; loc : int * int };; +type 'e name = { expr : 'e; tvar : string; loc : loc };; type styp = STlid of loc * string @@ -161,7 +161,12 @@ module MetaAction = in failwith (f ^ ", not impl: " ^ desc) ;; - let loc = 0, 0;; + let loc = + let nowhere = + {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0} + in + nowhere, nowhere + ;; let rec mlist mf = function [] -> MLast.ExUid (loc, "[]") @@ -181,7 +186,26 @@ module MetaAction = | true -> MLast.ExUid (loc, "True") ;; let mloc = - MLast.ExTup (loc, [MLast.ExInt (loc, "0"); MLast.ExInt (loc, "0")]) + MLast.ExLet + (loc, false, + [MLast.PaLid (loc, "nowhere"), + MLast.ExRec + (loc, + [MLast.PaAcc + (loc, MLast.PaUid (loc, "Lexing"), + MLast.PaLid (loc, "pos_lnum")), + MLast.ExInt (loc, "1"); + MLast.PaAcc + (loc, MLast.PaUid (loc, "Lexing"), + MLast.PaLid (loc, "pos_cnum")), + MLast.ExInt (loc, "0")], + Some + (MLast.ExAcc + (loc, MLast.ExUid (loc, "Lexing"), + MLast.ExLid (loc, "dummy_pos"))))], + MLast.ExTup + (loc, + [MLast.ExLid (loc, "nowhere"); MLast.ExLid (loc, "nowhere")])) ;; let rec mexpr = function @@ -809,7 +833,13 @@ let quotify_action psl act = (fun e ps -> match ps.pattern with Some (MLast.PaTup (_, pl)) -> - let loc = 0, 0 in + let loc = + let nowhere = + {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; + Lexing.pos_cnum = 0} + in + nowhere, nowhere + in let pname = pname_of_ptuple pl in let (pl1, el1) = let (l, _) = @@ -1040,7 +1070,13 @@ let text_of_action loc psl rtvar act tvar = [MLast.PaTyc (loc, locid, MLast.TyTup - (loc, [MLast.TyLid (loc, "int"); MLast.TyLid (loc, "int")])), + (loc, + [MLast.TyAcc + (loc, MLast.TyUid (loc, "Lexing"), + MLast.TyLid (loc, "position")); + MLast.TyAcc + (loc, MLast.TyUid (loc, "Lexing"), + MLast.TyLid (loc, "position"))])), None, MLast.ExTyc (loc, act, MLast.TyQuo (loc, rtvar))]) in let txt = @@ -1459,6 +1495,8 @@ let text_of_functorial_extend loc gmod gl el = let_in_of_extend loc gmod true gl el args ;; +let zero_loc = {(Lexing.dummy_pos) with Lexing.pos_cnum = 0};; + open Pcaml;; let symbol = Grammar.Entry.create gram "symbol";; let semi_sep = @@ -1518,26 +1556,34 @@ Grammar.extend (gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e)); Gramext.Stoken ("", "END")], Gramext.action - (fun _ (e : 'gdelete_rule_body) _ (loc : int * int) -> (e : 'expr)); + (fun _ (e : 'gdelete_rule_body) _ + (loc : Lexing.position * Lexing.position) -> + (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)); + (fun _ (e : 'delete_rule_body) _ + (loc : Lexing.position * Lexing.position) -> + (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)); + (fun _ (e : 'gextend_body) _ + (loc : Lexing.position * Lexing.position) -> + (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))]]; + (fun _ (e : 'extend_body) _ + (loc : Lexing.position * Lexing.position) -> + (e : 'expr))]]; Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e), None, [None, None, [[Gramext.Snterm @@ -1552,10 +1598,12 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], Gramext.action - (fun _ (e : 'entry) (loc : int * int) -> (e : 'e__1))])], + (fun _ (e : 'entry) + (loc : Lexing.position * Lexing.position) -> + (e : 'e__1))])], Gramext.action (fun (el : 'e__1 list) (sl : 'global option) (f : 'efunction) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (text_of_extend loc "Grammar" sl el f : 'extend_body))]]; Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e), None, [None, None, @@ -1570,10 +1618,12 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], Gramext.action - (fun _ (e : 'entry) (loc : int * int) -> (e : 'e__2))])], + (fun _ (e : 'entry) + (loc : Lexing.position * Lexing.position) -> + (e : 'e__2))])], Gramext.action (fun (el : 'e__2 list) (sl : 'global option) (g : string) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (text_of_functorial_extend loc g sl el : 'gextend_body))]]; Grammar.Entry.obj (delete_rule_body : 'delete_rule_body Grammar.Entry.e), None, @@ -1586,7 +1636,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], Gramext.action - (fun (sl : 'symbol list) _ (n : 'name) (loc : int * int) -> + (fun (sl : 'symbol list) _ (n : 'name) + (loc : Lexing.position * Lexing.position) -> (let (e, b) = expr_of_delete_rule loc "Grammar" n sl in MLast.ExApp (loc, @@ -1612,7 +1663,7 @@ Grammar.extend (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], Gramext.action (fun (sl : 'symbol list) _ (n : 'name) (g : string) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (let (e, b) = expr_of_delete_rule loc g n sl in MLast.ExApp (loc, @@ -1628,7 +1679,7 @@ Grammar.extend [None, None, [[], Gramext.action - (fun (loc : int * int) -> + (fun (loc : Lexing.position * Lexing.position) -> (MLast.ExAcc (loc, MLast.ExUid (loc, "Grammar"), MLast.ExLid (loc, "extend")) : @@ -1638,7 +1689,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], Gramext.action - (fun _ (f : 'qualid) _ _ (loc : int * int) -> (f : 'efunction))]]; + (fun _ (f : 'qualid) _ _ (loc : Lexing.position * Lexing.position) -> + (f : 'efunction))]]; Grammar.Entry.obj (global : 'global Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("UIDENT", "GLOBAL"); Gramext.Stoken ("", ":"); @@ -1647,7 +1699,9 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], Gramext.action - (fun _ (sl : 'name list) _ _ (loc : int * int) -> (sl : 'global))]]; + (fun _ (sl : 'name list) _ _ + (loc : Lexing.position * Lexing.position) -> + (sl : 'global))]]; Grammar.Entry.obj (entry : 'entry Grammar.Entry.e), None, [None, None, [[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); @@ -1659,14 +1713,14 @@ Grammar.extend (Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e))], Gramext.action (fun (ll : 'level_list) (pos : 'position option) _ (n : 'name) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> ({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) -> + (fun (n : 'string) _ (loc : Lexing.position * Lexing.position) -> (MLast.ExApp (loc, MLast.ExAcc @@ -1677,7 +1731,7 @@ Grammar.extend [Gramext.Stoken ("UIDENT", "AFTER"); Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], Gramext.action - (fun (n : 'string) _ (loc : int * int) -> + (fun (n : 'string) _ (loc : Lexing.position * Lexing.position) -> (MLast.ExApp (loc, MLast.ExAcc @@ -1688,7 +1742,7 @@ Grammar.extend [Gramext.Stoken ("UIDENT", "BEFORE"); Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], Gramext.action - (fun (n : 'string) _ (loc : int * int) -> + (fun (n : 'string) _ (loc : Lexing.position * Lexing.position) -> (MLast.ExApp (loc, MLast.ExAcc @@ -1698,13 +1752,13 @@ Grammar.extend 'position)); [Gramext.Stoken ("UIDENT", "LAST")], Gramext.action - (fun _ (loc : int * int) -> + (fun _ (loc : Lexing.position * Lexing.position) -> (MLast.ExAcc (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Last")) : 'position)); [Gramext.Stoken ("UIDENT", "FIRST")], Gramext.action - (fun _ (loc : int * int) -> + (fun _ (loc : Lexing.position * Lexing.position) -> (MLast.ExAcc (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "First")) : @@ -1717,7 +1771,8 @@ Grammar.extend Gramext.Stoken ("", "|")); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (ll : 'level list) _ (loc : int * int) -> + (fun _ (ll : 'level list) _ + (loc : Lexing.position * Lexing.position) -> (ll : 'level_list))]]; Grammar.Entry.obj (level : 'level Grammar.Entry.e), None, [None, None, @@ -1729,26 +1784,26 @@ Grammar.extend (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) -> + (loc : Lexing.position * Lexing.position) -> ({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) -> + (fun _ (loc : Lexing.position * Lexing.position) -> (MLast.ExAcc (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "NonA")) : 'assoc)); [Gramext.Stoken ("UIDENT", "RIGHTA")], Gramext.action - (fun _ (loc : int * int) -> + (fun _ (loc : Lexing.position * Lexing.position) -> (MLast.ExAcc (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "RightA")) : 'assoc)); [Gramext.Stoken ("UIDENT", "LEFTA")], Gramext.action - (fun _ (loc : int * int) -> + (fun _ (loc : Lexing.position * Lexing.position) -> (MLast.ExAcc (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "LeftA")) : @@ -1761,10 +1816,13 @@ Grammar.extend Gramext.Stoken ("", "|")); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (rules : 'rule list) _ (loc : int * int) -> + (fun _ (rules : 'rule list) _ + (loc : Lexing.position * Lexing.position) -> (retype_rule_list_without_patterns loc rules : 'rule_list)); [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action (fun _ _ (loc : int * int) -> ([] : 'rule_list))]]; + Gramext.action + (fun _ _ (loc : Lexing.position * Lexing.position) -> + ([] : 'rule_list))]]; Grammar.Entry.obj (rule : 'rule Grammar.Entry.e), None, [None, None, [[Gramext.Slist0sep @@ -1773,7 +1831,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], Gramext.action - (fun (psl : 'psymbol list) (loc : int * int) -> + (fun (psl : 'psymbol list) + (loc : Lexing.position * Lexing.position) -> ({prod = psl; action = None} : 'rule)); [Gramext.Slist0sep (Gramext.Snterm @@ -1783,20 +1842,22 @@ Grammar.extend Gramext.Stoken ("", "->"); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (act : 'expr) _ (psl : 'psymbol list) (loc : int * int) -> + (fun (act : 'expr) _ (psl : 'psymbol list) + (loc : Lexing.position * Lexing.position) -> ({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) -> + (fun (s : 'symbol) (loc : Lexing.position * Lexing.position) -> ({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) -> + (fun (s : 'symbol) _ (p : 'pattern) + (loc : Lexing.position * Lexing.position) -> ({pattern = Some p; symbol = s} : 'psymbol)); [Gramext.Stoken ("LIDENT", ""); Gramext.Sopt @@ -1804,9 +1865,12 @@ Grammar.extend [[Gramext.Stoken ("UIDENT", "LEVEL"); Gramext.Stoken ("STRING", "")], Gramext.action - (fun (s : string) _ (loc : int * int) -> (s : 'e__3))])], + (fun (s : string) _ + (loc : Lexing.position * Lexing.position) -> + (s : 'e__3))])], Gramext.action - (fun (lev : 'e__3 option) (i : string) (loc : int * int) -> + (fun (lev : 'e__3 option) (i : string) + (loc : Lexing.position * Lexing.position) -> (let name = mk_name loc (MLast.ExLid (loc, i)) in let text = TXnterm (loc, name, lev) in let styp = STquo (loc, i) in @@ -1816,14 +1880,15 @@ Grammar.extend [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) -> + (fun (s : 'symbol) _ (p : string) + (loc : Lexing.position * Lexing.position) -> ({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) -> + (fun (s : 'symbol) _ (loc : Lexing.position * Lexing.position) -> (if !quotify then ssopt loc s else let styp = STapp (loc, STlid (loc, "option"), s.styp) in @@ -1837,9 +1902,12 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], Gramext.action - (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__5))])], + (fun (t : 'symbol) _ + (loc : Lexing.position * Lexing.position) -> + (t : 'e__5))])], Gramext.action - (fun (sep : 'e__5 option) (s : 'symbol) _ (loc : int * int) -> + (fun (sep : 'e__5 option) (s : 'symbol) _ + (loc : Lexing.position * Lexing.position) -> (if !quotify then sslist loc true sep s else let used = @@ -1858,9 +1926,12 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], Gramext.action - (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__4))])], + (fun (t : 'symbol) _ + (loc : Lexing.position * Lexing.position) -> + (t : 'e__4))])], Gramext.action - (fun (sep : 'e__4 option) (s : 'symbol) _ (loc : int * int) -> + (fun (sep : 'e__4 option) (s : 'symbol) _ + (loc : Lexing.position * Lexing.position) -> (if !quotify then sslist loc false sep s else let used = @@ -1875,16 +1946,20 @@ Grammar.extend None, None, [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (s_t : 'symbol) _ (loc : int * int) -> (s_t : 'symbol)); + (fun _ (s_t : 'symbol) _ (loc : Lexing.position * Lexing.position) -> + (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))])], + (fun (s : string) _ + (loc : Lexing.position * Lexing.position) -> + (s : 'e__7))])], Gramext.action - (fun (lev : 'e__7 option) (n : 'name) (loc : int * int) -> + (fun (lev : 'e__7 option) (n : 'name) + (loc : Lexing.position * Lexing.position) -> ({used = [n.tvar]; text = TXnterm (loc, n, lev); styp = STquo (loc, n.tvar)} : 'symbol)); @@ -1895,10 +1970,12 @@ Grammar.extend [[Gramext.Stoken ("UIDENT", "LEVEL"); Gramext.Stoken ("STRING", "")], Gramext.action - (fun (s : string) _ (loc : int * int) -> (s : 'e__6))])], + (fun (s : string) _ + (loc : Lexing.position * Lexing.position) -> + (s : 'e__6))])], Gramext.action (fun (lev : 'e__6 option) (e : 'qualid) _ (i : string) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (let n = mk_name loc (MLast.ExAcc (loc, MLast.ExUid (loc, i), e)) in @@ -1907,20 +1984,21 @@ Grammar.extend 'symbol)); [Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], Gramext.action - (fun (e : 'string) (loc : int * int) -> + (fun (e : 'string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'string) (x : string) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (x : string) (loc : Lexing.position * Lexing.position) -> (let text = if !quotify then sstoken loc x else TXtok (loc, x, MLast.ExStr (loc, "")) @@ -1933,7 +2011,8 @@ Grammar.extend Gramext.Stoken ("", "|")); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (rl : 'rule list) _ (loc : int * int) -> + (fun _ (rl : 'rule list) _ + (loc : Lexing.position * Lexing.position) -> (let rl = retype_rule_list_without_patterns loc rl in let t = new_type_var () in {used = used_of_rule_list rl; @@ -1942,12 +2021,12 @@ Grammar.extend 'symbol)); [Gramext.Stoken ("UIDENT", "NEXT")], Gramext.action - (fun _ (loc : int * int) -> + (fun _ (loc : Lexing.position * Lexing.position) -> ({used = []; text = TXnext loc; styp = STself (loc, "NEXT")} : 'symbol)); [Gramext.Stoken ("UIDENT", "SELF")], Gramext.action - (fun _ (loc : int * int) -> + (fun _ (loc : Lexing.position * Lexing.position) -> ({used = []; text = TXself loc; styp = STself (loc, "SELF")} : 'symbol))]]; Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e), None, @@ -1958,17 +2037,20 @@ Grammar.extend (patterns_comma : 'patterns_comma Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (pl : 'patterns_comma) _ (p : 'pattern) _ (loc : int * int) -> + (fun _ (pl : 'patterns_comma) _ (p : 'pattern) _ + (loc : Lexing.position * Lexing.position) -> (MLast.PaTup (loc, (p :: pl)) : 'pattern)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (p : 'pattern) _ (loc : int * int) -> (p : 'pattern)); + (fun _ (p : 'pattern) _ (loc : Lexing.position * Lexing.position) -> + (p : 'pattern)); [Gramext.Stoken ("", "_")], Gramext.action - (fun _ (loc : int * int) -> (MLast.PaAny loc : 'pattern)); + (fun _ (loc : Lexing.position * Lexing.position) -> + (MLast.PaAny loc : 'pattern)); [Gramext.Stoken ("LIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaLid (loc, i) : 'pattern))]]; Grammar.Entry.obj (patterns_comma : 'patterns_comma Grammar.Entry.e), None, @@ -1977,49 +2059,54 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))], Gramext.action - (fun (p : 'pattern) _ (pl : 'patterns_comma) (loc : int * int) -> + (fun (p : 'pattern) _ (pl : 'patterns_comma) + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (p : 'pattern) (loc : Lexing.position * Lexing.position) -> + ([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))]]; + (fun (e : 'qualid) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (e2 : 'qualid) _ (e1 : 'qualid) + (loc : Lexing.position * Lexing.position) -> (MLast.ExAcc (loc, e1, e2) : 'qualid))]; None, None, [[Gramext.Stoken ("LIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExLid (loc, i) : 'qualid)); [Gramext.Stoken ("UIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (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 + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + (let shift = Reloc.shift_pos (String.length "$") (fst loc) 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 + raise_with_loc (Reloc.adjust_loc shift (bp, ep)) exc in - Pcaml.expr_reloc (fun (bp, ep) -> shift + bp, shift + ep) 0 e : + Pcaml.expr_reloc (fun (bp, ep) -> Reloc.adjust_loc shift (bp, ep)) + zero_loc e : 'string)); [Gramext.Stoken ("STRING", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExStr (loc, s) : 'string))]]]);; Pcaml.add_option "-quotify" (Arg.Set quotify) "Generate code for quotations";; diff --git a/camlp4/ocaml_src/meta/pa_extend_m.ml b/camlp4/ocaml_src/meta/pa_extend_m.ml index 11fd07f5..c6da0eb8 100644 --- a/camlp4/ocaml_src/meta/pa_extend_m.ml +++ b/camlp4/ocaml_src/meta/pa_extend_m.ml @@ -20,12 +20,17 @@ Grammar.extend [None, Some Gramext.NonA, [[Gramext.Stoken ("UIDENT", "SOPT"); Gramext.Sself], Gramext.action - (fun (s : 'symbol) _ (loc : int * int) -> (ssopt loc s : 'symbol)); + (fun (s : 'symbol) _ (loc : Lexing.position * Lexing.position) -> + (ssopt loc s : 'symbol)); [Gramext.srules [[Gramext.Stoken ("UIDENT", "SLIST1")], - Gramext.action (fun _ (loc : int * int) -> (true : 'e__1)); + Gramext.action + (fun _ (loc : Lexing.position * Lexing.position) -> + (true : 'e__1)); [Gramext.Stoken ("UIDENT", "SLIST0")], - Gramext.action (fun _ (loc : int * int) -> (false : 'e__1))]; + Gramext.action + (fun _ (loc : Lexing.position * Lexing.position) -> + (false : 'e__1))]; Gramext.Sself; Gramext.Sopt (Gramext.srules @@ -33,8 +38,10 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], Gramext.action - (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__2))])], + (fun (t : 'symbol) _ + (loc : Lexing.position * Lexing.position) -> + (t : 'e__2))])], Gramext.action (fun (sep : 'e__2 option) (s : 'symbol) (min : 'e__1) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (sslist loc min sep s : 'symbol))]]];; diff --git a/camlp4/ocaml_src/meta/pa_ifdef.ml b/camlp4/ocaml_src/meta/pa_ifdef.ml deleted file mode 100644 index 6384d6be..00000000 --- a/camlp4/ocaml_src/meta/pa_ifdef.ml +++ /dev/null @@ -1,216 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* This file has been generated by program: do not edit! *) - -type 'a item_or_def = - SdStr of 'a - | SdDef of string - | SdUnd of string - | SdNop -;; - -let list_remove x l = - List.fold_right (fun e l -> if e = x then l else e :: l) l [] -;; - -let defined = ref ["OCAML_305"; "CAMLP4_300"; "NEWSEQ"];; -let define x = defined := x :: !defined;; -let undef x = defined := list_remove x !defined;; - -Grammar.extend - (let _ = (Pcaml.expr : 'Pcaml__expr Grammar.Entry.e) - and _ = (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e) - and _ = (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry Pcaml.expr) s - in - let def_undef_str : 'def_undef_str Grammar.Entry.e = - grammar_entry_create "def_undef_str" - and str_item_def_undef : 'str_item_def_undef Grammar.Entry.e = - grammar_entry_create "str_item_def_undef" - and def_undef_sig : 'def_undef_sig Grammar.Entry.e = - grammar_entry_create "def_undef_sig" - and sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e = - grammar_entry_create "sig_item_def_undef" - in - [Grammar.Entry.obj (Pcaml.expr : 'Pcaml__expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); Gramext.Sself; - Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e2 : 'Pcaml__expr) _ (e1 : 'Pcaml__expr) _ (c : string) _ - (loc : int * int) -> - (if List.mem c !defined then e2 else e1 : 'Pcaml__expr)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); Gramext.Sself; - Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e2 : 'Pcaml__expr) _ (e1 : 'Pcaml__expr) _ (c : string) _ - (loc : int * int) -> - (if List.mem c !defined then e1 else e2 : 'Pcaml__expr))]]; - Grammar.Entry.obj (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e), - Some Gramext.First, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (def_undef_str : 'def_undef_str Grammar.Entry.e))], - Gramext.action - (fun (x : 'def_undef_str) (loc : int * int) -> - (match x with - SdStr si -> si - | SdDef x -> define x; MLast.StDcl (loc, []) - | SdUnd x -> undef x; MLast.StDcl (loc, []) - | SdNop -> MLast.StDcl (loc, []) : - 'Pcaml__str_item))]]; - Grammar.Entry.obj (def_undef_str : 'def_undef_str Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "undef"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdUnd c : 'def_undef_str)); - [Gramext.Stoken ("", "define"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdDef c : 'def_undef_str)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'str_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then SdNop else e1 : 'def_undef_str)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'str_item_def_undef) _ (e1 : 'str_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e2 else e1 : 'def_undef_str)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'str_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else SdNop : 'def_undef_str)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'str_item_def_undef) _ (e1 : 'str_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else e2 : 'def_undef_str))]]; - Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e))], - Gramext.action - (fun (si : 'Pcaml__str_item) (loc : int * int) -> - (SdStr si : 'str_item_def_undef)); - [Gramext.Snterm - (Grammar.Entry.obj - (def_undef_str : 'def_undef_str Grammar.Entry.e))], - Gramext.action - (fun (d : 'def_undef_str) (loc : int * int) -> - (d : 'str_item_def_undef))]]; - Grammar.Entry.obj (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e), - Some Gramext.First, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (def_undef_sig : 'def_undef_sig Grammar.Entry.e))], - Gramext.action - (fun (x : 'def_undef_sig) (loc : int * int) -> - (match x with - SdStr si -> si - | SdDef x -> define x; MLast.SgDcl (loc, []) - | SdUnd x -> undef x; MLast.SgDcl (loc, []) - | SdNop -> MLast.SgDcl (loc, []) : - 'Pcaml__sig_item))]]; - Grammar.Entry.obj (def_undef_sig : 'def_undef_sig Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "undef"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdUnd c : 'def_undef_sig)); - [Gramext.Stoken ("", "define"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdDef c : 'def_undef_sig)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'sig_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then SdNop else e1 : 'def_undef_sig)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'sig_item_def_undef) _ (e1 : 'sig_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e2 else e1 : 'def_undef_sig)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'sig_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else SdNop : 'def_undef_sig)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'sig_item_def_undef) _ (e1 : 'sig_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else e2 : 'def_undef_sig))]]; - Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e))], - Gramext.action - (fun (si : 'Pcaml__sig_item) (loc : int * int) -> - (SdStr si : 'sig_item_def_undef)); - [Gramext.Snterm - (Grammar.Entry.obj - (def_undef_sig : 'def_undef_sig Grammar.Entry.e))], - Gramext.action - (fun (d : 'def_undef_sig) (loc : int * int) -> - (d : 'sig_item_def_undef))]]]);; - -Pcaml.add_option "-D" (Arg.String define) - " Define for ifdef instruction.";; -Pcaml.add_option "-U" (Arg.String undef) - " Undefine for ifdef instruction.";; diff --git a/camlp4/ocaml_src/meta/pa_macro.ml b/camlp4/ocaml_src/meta/pa_macro.ml index 599608f9..9a1b8504 100644 --- a/camlp4/ocaml_src/meta/pa_macro.ml +++ b/camlp4/ocaml_src/meta/pa_macro.ml @@ -9,33 +9,43 @@ Added statements: DEFINE DEFINE = DEFINE () = - IFDEF THEN END - IFDEF THEN ELSE END - IFNDEF THEN END - IFNDEF THEN ELSE END + IFDEF THEN (END | ENDIF) + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) + INCLUDE In expressions: - IFDEF THEN ELSE END - IFNDEF THEN ELSE END + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) __FILE__ __LOCATION__ In patterns: - IFDEF THEN ELSE END - IFNDEF THEN ELSE END + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) As Camlp4 options: - -D - -U + -D define + -U undefine it + -I add to the search path for INCLUDE'd files 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 toplevel statement INCLUDE can be used to include a + file containing macro definitions; note that files included in such + a way can not have any non-macro toplevel items. The included files + are looked up in directories passed in via the -I option, falling + back to the current directory. + The expression __FILE__ returns the current compiled file name. The expression __LOCATION__ returns the current location of itself. @@ -50,7 +60,8 @@ type 'a item_or_def = SdStr of 'a | SdDef of string * (string list * MLast.expr) option | SdUnd of string - | SdNop + | SdITE of string * 'a item_or_def list * 'a item_or_def list + | SdInc of string ;; let rec list_remove x = @@ -64,7 +75,12 @@ let defined = ref [];; let is_defined i = List.mem_assoc i !defined;; -let loc = 0, 0;; +let loc = + let nowhere = + {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0} + in + nowhere, nowhere +;; let subst mloc env = let rec loop = @@ -75,15 +91,32 @@ let subst mloc env = | MLast.ExIfe (_, e1, e2, e3) -> MLast.ExIfe (loc, loop e1, loop e2, loop e3) | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, loop e1, loop e2) + | MLast.ExFun (_, [args, None, e]) -> + MLast.ExFun (loc, [args, None, loop e]) + | MLast.ExFun (_, peoel) -> MLast.ExFun (loc, List.map loop_peoel peoel) | MLast.ExLid (_, x) | MLast.ExUid (_, x) as e -> begin try MLast.ExAnt (loc, List.assoc x env) with Not_found -> e end | MLast.ExTup (_, x) -> MLast.ExTup (loc, List.map loop x) + | MLast.ExSeq (_, x) -> MLast.ExSeq (loc, List.map loop x) | MLast.ExRec (_, pel, None) -> let pel = List.map (fun (p, e) -> p, loop e) pel in MLast.ExRec (loc, pel, None) + | MLast.ExMat (_, e, peoel) -> + MLast.ExMat (loc, loop e, List.map loop_peoel peoel) + | MLast.ExTry (_, e, pel) -> + let loop' = + function + p, Some e1, e2 -> p, Some (loop e1), loop e2 + | p, None, e2 -> p, None, loop e2 + in + MLast.ExTry (loc, loop e, List.map loop' pel) | e -> e + and loop_peoel = + function + p, Some e1, e2 -> p, Some (loop e1), loop e2 + | p, None, e2 -> p, None, loop e2 in loop ;; @@ -101,6 +134,7 @@ let substp mloc env = Not_found -> MLast.PaUid (loc, x) end | MLast.ExInt (_, x) -> MLast.PaInt (loc, x) + | MLast.ExStr (_, s) -> MLast.PaStr (loc, s) | MLast.ExTup (_, x) -> MLast.PaTup (loc, List.map loop x) | MLast.ExRec (_, pel, None) -> let ppl = List.map (fun (p, e) -> p, loop e) pel in @@ -129,16 +163,16 @@ let define eo x = [None, None, [[Gramext.Stoken ("UIDENT", x)], Gramext.action - (fun _ (loc : int * int) -> - (Pcaml.expr_reloc (fun _ -> loc) 0 e : 'expr))]]; + (fun _ (loc : Lexing.position * Lexing.position) -> + (Pcaml.expr_reloc (fun _ -> loc) (fst loc) 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) -> + (fun _ (loc : Lexing.position * Lexing.position) -> (let p = substp loc [] e in - Pcaml.patt_reloc (fun _ -> loc) 0 p : + Pcaml.patt_reloc (fun _ -> loc) (fst loc) p : 'patt))]]] | Some (sl, e) -> Grammar.extend @@ -147,7 +181,8 @@ let define eo x = [None, None, [[Gramext.Stoken ("UIDENT", x); Gramext.Sself], Gramext.action - (fun (param : 'expr) _ (loc : int * int) -> + (fun (param : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (let el = match param with MLast.ExTup (_, el) -> el @@ -156,7 +191,7 @@ let define eo x = 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 + Pcaml.expr_reloc (fun _ -> loc) (fst loc) e else incorrect_number loc el sl : 'expr))]]; Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), @@ -164,7 +199,8 @@ let define eo x = [None, None, [[Gramext.Stoken ("UIDENT", x); Gramext.Sself], Gramext.action - (fun (param : 'patt) _ (loc : int * int) -> + (fun (param : 'patt) _ + (loc : Lexing.position * Lexing.position) -> (let pl = match param with MLast.PaTup (_, pl) -> pl @@ -173,7 +209,7 @@ let define eo x = 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 + Pcaml.patt_reloc (fun _ -> loc) (fst loc) p else incorrect_number loc pl sl : 'patt))]]] | None -> () @@ -199,16 +235,61 @@ let undef x = Not_found -> () ;; +(* This is a list of directories to search for INCLUDE statements. *) +let include_dirs = ref [];; + +(* Add something to the above, make sure it ends with a slash. *) +let add_include_dir str = + if str <> "" then + let str = + if String.get str (String.length str - 1) = '/' then str else str ^ "/" + in + include_dirs := !include_dirs @ [str] +;; + +let smlist = Grammar.Entry.create Pcaml.gram "smlist";; + +let parse_include_file = + let dir_ok file dir = Sys.file_exists (dir ^ file) in + fun file -> + let file = + try List.find (dir_ok file) (!include_dirs @ ["./"]) ^ file with + Not_found -> file + in + let st = Stream.of_channel (open_in file) in + let old_input = !(Pcaml.input_file) in + Pcaml.input_file := file; + let items = Grammar.Entry.parse smlist st in + Pcaml.input_file := old_input; items +;; + +let rec execute_macro = + function + SdStr i -> [i] + | SdDef (x, eo) -> define eo x; [] + | SdUnd x -> undef x; [] + | SdITE (i, l1, l2) -> execute_macro_list (if is_defined i then l1 else l2) + | SdInc f -> execute_macro_list (parse_include_file f) +and execute_macro_list = + function + [] -> [] + | hd :: tl -> + let il1 = execute_macro hd in + let il2 = execute_macro_list tl in il1 @ il2 +;; + Grammar.extend (let _ = (expr : 'expr Grammar.Entry.e) and _ = (patt : 'patt Grammar.Entry.e) and _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (sig_item : 'sig_item Grammar.Entry.e) in + and _ = (sig_item : 'sig_item Grammar.Entry.e) + and _ = (smlist : 'smlist Grammar.Entry.e) in let grammar_entry_create s = Grammar.Entry.create (Grammar.of_entry expr) s in let macro_def : 'macro_def Grammar.Entry.e = grammar_entry_create "macro_def" + and endif : 'endif Grammar.Entry.e = grammar_entry_create "endif" and str_item_or_macro : 'str_item_or_macro Grammar.Entry.e = grammar_entry_create "str_item_or_macro" and opt_macro_value : 'opt_macro_value Grammar.Entry.e = @@ -220,101 +301,114 @@ Grammar.extend [[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, []) : + (fun (x : 'macro_def) (loc : Lexing.position * Lexing.position) -> + (match execute_macro x with + [si] -> si + | sil -> MLast.StDcl (loc, sil) : 'str_item))]]; Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e), None, [None, None, - [[Gramext.Stoken ("", "IFNDEF"); + [[Gramext.Stoken ("", "INCLUDE"); Gramext.Stoken ("STRING", "")], + Gramext.action + (fun (fname : string) _ (loc : Lexing.position * Lexing.position) -> + (SdInc fname : 'macro_def)); + [Gramext.Stoken ("", "IFNDEF"); Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); + Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); Gramext.Stoken ("", "ELSE"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], + Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); + Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], Gramext.action - (fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _ - (i : 'uident) _ (loc : int * int) -> - (if is_defined i then d2 else d1 : 'macro_def)); + (fun (_ : 'endif) (dl2 : 'smlist) _ (dl1 : 'smlist) _ (i : 'uident) _ + (loc : Lexing.position * Lexing.position) -> + (SdITE (i, dl2, dl1) : 'macro_def)); [Gramext.Stoken ("", "IFNDEF"); Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], + Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); + Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], Gramext.action - (fun _ (d : 'str_item_or_macro) _ (i : 'uident) _ (loc : int * int) -> - (if is_defined i then SdNop else d : 'macro_def)); + (fun (_ : 'endif) (dl : 'smlist) _ (i : 'uident) _ + (loc : Lexing.position * Lexing.position) -> + (SdITE (i, [], dl) : 'macro_def)); [Gramext.Stoken ("", "IFDEF"); Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); + Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); Gramext.Stoken ("", "ELSE"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], + Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); + Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], Gramext.action - (fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _ - (i : 'uident) _ (loc : int * int) -> - (if is_defined i then d1 else d2 : 'macro_def)); + (fun (_ : 'endif) (dl2 : 'smlist) _ (dl1 : 'smlist) _ (i : 'uident) _ + (loc : Lexing.position * Lexing.position) -> + (SdITE (i, dl1, dl2) : 'macro_def)); [Gramext.Stoken ("", "IFDEF"); Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], + Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); + Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], Gramext.action - (fun _ (d : 'str_item_or_macro) _ (i : 'uident) _ (loc : int * int) -> - (if is_defined i then d else SdNop : 'macro_def)); + (fun (_ : 'endif) (dl : 'smlist) _ (i : 'uident) _ + (loc : Lexing.position * Lexing.position) -> + (SdITE (i, dl, []) : 'macro_def)); [Gramext.Stoken ("", "UNDEF"); Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e))], Gramext.action - (fun (i : 'uident) _ (loc : int * int) -> (SdUnd i : 'macro_def)); + (fun (i : 'uident) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (def : 'opt_macro_value) (i : 'uident) _ + (loc : Lexing.position * Lexing.position) -> (SdDef (i, def) : 'macro_def))]]; + Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e), None, + [None, None, + [[Gramext.Slist1 + (Gramext.Snterm + (Grammar.Entry.obj + (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)))], + Gramext.action + (fun (sml : 'str_item_or_macro list) + (loc : Lexing.position * Lexing.position) -> + (sml : 'smlist))]]; + Grammar.Entry.obj (endif : 'endif Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("", "ENDIF")], + Gramext.action + (fun _ (loc : Lexing.position * Lexing.position) -> (() : 'endif)); + [Gramext.Stoken ("", "END")], + Gramext.action + (fun _ (loc : Lexing.position * Lexing.position) -> (() : 'endif))]]; Grammar.Entry.obj (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e), None, [None, None, - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)))], + [[Gramext.Snterm + (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e))], Gramext.action - (fun (si : 'str_item list) (loc : int * int) -> + (fun (si : 'str_item) (loc : Lexing.position * Lexing.position) -> (SdStr si : 'str_item_or_macro)); [Gramext.Snterm (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))], Gramext.action - (fun (d : 'macro_def) (loc : int * int) -> + (fun (d : 'macro_def) (loc : Lexing.position * Lexing.position) -> (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.action + (fun (loc : Lexing.position * Lexing.position) -> + (None : 'opt_macro_value)); [Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (Some ([], e) : 'opt_macro_value)); [Gramext.Stoken ("", "("); Gramext.Slist1sep @@ -322,7 +416,8 @@ Grammar.extend 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) -> + (fun (e : 'expr) _ _ (pl : string list) _ + (loc : Lexing.position * Lexing.position) -> (Some (pl, e) : 'opt_macro_value))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "top"), @@ -331,34 +426,34 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); Gramext.Stoken ("", "THEN"); Gramext.Sself; Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], + Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ - (loc : int * int) -> + (fun (_ : 'endif) (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ + (loc : Lexing.position * Lexing.position) -> (if is_defined i then e2 else e1 : 'expr)); [Gramext.Stoken ("", "IFDEF"); Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); Gramext.Stoken ("", "THEN"); Gramext.Sself; Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], + Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ - (loc : int * int) -> + (fun (_ : 'endif) (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ + (loc : Lexing.position * Lexing.position) -> (if is_defined i then e1 else e2 : 'expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), 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 + (fun _ (loc : Lexing.position * Lexing.position) -> + (let bp = string_of_int (fst loc).Lexing.pos_cnum in + let ep = string_of_int (snd loc).Lexing.pos_cnum in MLast.ExTup (loc, [MLast.ExInt (loc, bp); MLast.ExInt (loc, ep)]) : 'expr)); [Gramext.Stoken ("LIDENT", "__FILE__")], Gramext.action - (fun _ (loc : int * int) -> + (fun _ (loc : Lexing.position * Lexing.position) -> (MLast.ExStr (loc, !(Pcaml.input_file)) : 'expr))]]; Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, [None, None, @@ -366,27 +461,30 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); Gramext.Stoken ("", "THEN"); Gramext.Sself; Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], + Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], Gramext.action - (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ - (loc : int * int) -> + (fun (_ : 'endif) (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ + (loc : Lexing.position * Lexing.position) -> (if is_defined i then p2 else p1 : 'patt)); [Gramext.Stoken ("", "IFDEF"); Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); Gramext.Stoken ("", "THEN"); Gramext.Sself; Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], + Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], Gramext.action - (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ - (loc : int * int) -> + (fun (_ : 'endif) (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ + (loc : Lexing.position * Lexing.position) -> (if is_defined i then p1 else p2 : 'patt))]]; Grammar.Entry.obj (uident : 'uident Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("UIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> (i : 'uident))]]]);; + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + (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.";; +Pcaml.add_option "-I" (Arg.String add_include_dir) + " Add a directory to INCLUDE search path.";; diff --git a/camlp4/ocaml_src/meta/pa_r.ml b/camlp4/ocaml_src/meta/pa_r.ml index 013adfa8..b380dbce 100644 --- a/camlp4/ocaml_src/meta/pa_r.ml +++ b/camlp4/ocaml_src/meta/pa_r.ml @@ -19,16 +19,7 @@ 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. -"; +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; doneTo avoid compilation warning use the new syntax."; flush stderr; exit 1 ;; @@ -282,6 +273,8 @@ Grammar.extend grammar_entry_create "class_type_declaration" and field_expr : 'field_expr Grammar.Entry.e = grammar_entry_create "field_expr" + and meth_list : 'meth_list Grammar.Entry.e = + grammar_entry_create "meth_list" 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 = @@ -312,10 +305,13 @@ Grammar.extend (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> (s : 'e__1))]); + (fun _ (s : 'str_item) + (loc : Lexing.position * Lexing.position) -> + (s : 'e__1))]); Gramext.Stoken ("", "end")], Gramext.action - (fun _ (st : 'e__1 list) _ (loc : int * int) -> + (fun _ (st : 'e__1 list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.MeStr (loc, st) : 'module_expr)); [Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); @@ -324,22 +320,25 @@ Grammar.extend Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], Gramext.action (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : string) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (me2 : 'module_expr) (me1 : 'module_expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (me2 : 'module_expr) _ (me1 : 'module_expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (me : 'module_expr) _ + (loc : Lexing.position * Lexing.position) -> (me : 'module_expr)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); Gramext.Snterm @@ -347,17 +346,17 @@ Grammar.extend Gramext.Stoken ("", ")")], Gramext.action (fun _ (mt : 'module_type) _ (me : 'module_expr) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.MeTyc (loc, me, mt) : 'module_expr)); [Gramext.Stoken ("UIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'expr) (loc : Lexing.position * Lexing.position) -> (MLast.StExp (loc, e) : 'str_item)); [Gramext.Stoken ("", "value"); Gramext.Sopt (Gramext.Stoken ("", "rec")); @@ -367,7 +366,7 @@ Grammar.extend Gramext.Stoken ("", "and"))], Gramext.action (fun (l : 'let_binding list) (r : string option) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.StVal (loc, o2b r, l) : 'str_item)); [Gramext.Stoken ("", "type"); Gramext.Slist1sep @@ -376,20 +375,22 @@ Grammar.extend (type_declaration : 'type_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (tdl : 'type_declaration list) _ (loc : int * int) -> + (fun (tdl : 'type_declaration list) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'mod_ident) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (mt : 'module_type) _ (i : string) _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.StMty (loc, i, mt) : 'str_item)); [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); Gramext.Slist1sep @@ -398,20 +399,23 @@ Grammar.extend (module_rec_binding : 'module_rec_binding Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (nmtmes : 'module_rec_binding list) _ _ (loc : int * int) -> + (fun (nmtmes : 'module_rec_binding list) _ _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (mb : 'module_binding) (i : string) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (me : 'module_expr) _ + (loc : Lexing.position * Lexing.position) -> (MLast.StInc (loc, me) : 'str_item)); [Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); @@ -420,7 +424,7 @@ Grammar.extend Gramext.Slist1 (Gramext.Stoken ("STRING", ""))], Gramext.action (fun (pd : string list) _ (t : 'ctyp) _ (i : string) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.StExt (loc, i, t, pd) : 'str_item)); [Gramext.Stoken ("", "exception"); Gramext.Snterm @@ -431,7 +435,7 @@ Grammar.extend (Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))], Gramext.action (fun (b : 'rebind_exn) (_, c, tl : 'constructor_declaration) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.StExc (loc, c, tl, b) : 'str_item)); [Gramext.Stoken ("", "declare"); Gramext.Slist0 @@ -440,19 +444,25 @@ Grammar.extend (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> (s : 'e__2))]); + (fun _ (s : 'str_item) + (loc : Lexing.position * Lexing.position) -> + (s : 'e__2))]); Gramext.Stoken ("", "end")], Gramext.action - (fun _ (st : 'e__2 list) _ (loc : int * int) -> + (fun _ (st : 'e__2 list) _ + (loc : Lexing.position * Lexing.position) -> (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.action + (fun (loc : Lexing.position * Lexing.position) -> ([] : '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))]]; + (fun (sl : 'mod_ident) _ (loc : Lexing.position * Lexing.position) -> + (sl : 'rebind_exn))]]; Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e), None, [None, Some Gramext.RightA, @@ -460,7 +470,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], Gramext.action - (fun (me : 'module_expr) _ (loc : int * int) -> + (fun (me : 'module_expr) _ + (loc : Lexing.position * Lexing.position) -> (me : 'module_binding)); [Gramext.Stoken ("", ":"); Gramext.Snterm @@ -469,7 +480,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (loc : int * int) -> + (fun (me : 'module_expr) _ (mt : 'module_type) _ + (loc : Lexing.position * Lexing.position) -> (MLast.MeTyc (loc, me, mt) : 'module_binding)); [Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); @@ -478,7 +490,7 @@ Grammar.extend Gramext.Stoken ("", ")"); Gramext.Sself], Gramext.action (fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : string) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.MeFun (loc, m, mt, mb) : 'module_binding))]]; Grammar.Entry.obj (module_rec_binding : 'module_rec_binding Grammar.Entry.e), @@ -492,7 +504,7 @@ Grammar.extend (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], Gramext.action (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : string) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (m, mt, me : 'module_rec_binding))]]; Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None, [None, None, @@ -501,7 +513,7 @@ Grammar.extend Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], Gramext.action (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : string) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.MtFun (loc, i, t, mt) : 'module_type))]; None, None, [[Gramext.Sself; Gramext.Stoken ("", "with"); @@ -511,7 +523,7 @@ Grammar.extend Gramext.Stoken ("", "and"))], Gramext.action (fun (wcl : 'with_constr list) _ (mt : 'module_type) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.MtWit (loc, mt, wcl) : 'module_type))]; None, None, [[Gramext.Stoken ("", "sig"); @@ -521,38 +533,44 @@ Grammar.extend (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> (s : 'e__3))]); + (fun _ (s : 'sig_item) + (loc : Lexing.position * Lexing.position) -> + (s : 'e__3))]); Gramext.Stoken ("", "end")], Gramext.action - (fun _ (sg : 'e__3 list) _ (loc : int * int) -> + (fun _ (sg : 'e__3 list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.MtSig (loc, sg) : 'module_type))]; None, None, [[Gramext.Sself; Gramext.Sself], Gramext.action - (fun (m2 : 'module_type) (m1 : 'module_type) (loc : int * int) -> + (fun (m2 : 'module_type) (m1 : 'module_type) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (m2 : 'module_type) _ (m1 : 'module_type) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (mt : 'module_type) _ + (loc : Lexing.position * Lexing.position) -> (mt : 'module_type)); [Gramext.Stoken ("", "'"); Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> (MLast.MtQuo (loc, i) : 'module_type)); [Gramext.Stoken ("LIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.MtLid (loc, i) : 'module_type)); [Gramext.Stoken ("UIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.MtUid (loc, i) : 'module_type))]]; Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, [Some "top", None, @@ -560,7 +578,8 @@ Grammar.extend Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (i : string) _ (loc : int * int) -> + (fun (t : 'ctyp) _ (i : string) _ + (loc : Lexing.position * Lexing.position) -> (MLast.SgVal (loc, i, t) : 'sig_item)); [Gramext.Stoken ("", "type"); Gramext.Slist1sep @@ -569,20 +588,22 @@ Grammar.extend (type_declaration : 'type_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (tdl : 'type_declaration list) _ (loc : int * int) -> + (fun (tdl : 'type_declaration list) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'mod_ident) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (mt : 'module_type) _ (i : string) _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.SgMty (loc, i, mt) : 'sig_item)); [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); Gramext.Slist1sep @@ -592,20 +613,23 @@ Grammar.extend 'module_rec_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (mds : 'module_rec_declaration list) _ _ (loc : int * int) -> + (fun (mds : 'module_rec_declaration list) _ _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (mt : 'module_declaration) (i : string) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (mt : 'module_type) _ + (loc : Lexing.position * Lexing.position) -> (MLast.SgInc (loc, mt) : 'sig_item)); [Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); @@ -614,7 +638,7 @@ Grammar.extend Gramext.Slist1 (Gramext.Stoken ("STRING", ""))], Gramext.action (fun (pd : string list) _ (t : 'ctyp) _ (i : string) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.SgExt (loc, i, t, pd) : 'sig_item)); [Gramext.Stoken ("", "exception"); Gramext.Snterm @@ -622,7 +646,8 @@ Grammar.extend (constructor_declaration : 'constructor_declaration Grammar.Entry.e))], Gramext.action - (fun (_, c, tl : 'constructor_declaration) _ (loc : int * int) -> + (fun (_, c, tl : 'constructor_declaration) _ + (loc : Lexing.position * Lexing.position) -> (MLast.SgExc (loc, c, tl) : 'sig_item)); [Gramext.Stoken ("", "declare"); Gramext.Slist0 @@ -631,10 +656,13 @@ Grammar.extend (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> (s : 'e__4))]); + (fun _ (s : 'sig_item) + (loc : Lexing.position * Lexing.position) -> + (s : 'e__4))]); Gramext.Stoken ("", "end")], Gramext.action - (fun _ (st : 'e__4 list) _ (loc : int * int) -> + (fun _ (st : 'e__4 list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.SgDcl (loc, st) : 'sig_item))]]; Grammar.Entry.obj (module_declaration : 'module_declaration Grammar.Entry.e), @@ -647,13 +675,14 @@ Grammar.extend Gramext.Stoken ("", ")"); Gramext.Sself], Gramext.action (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : string) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (mt : 'module_type) _ + (loc : Lexing.position * Lexing.position) -> (mt : 'module_declaration))]]; Grammar.Entry.obj (module_rec_declaration : 'module_rec_declaration Grammar.Entry.e), @@ -663,7 +692,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], Gramext.action - (fun (mt : 'module_type) _ (m : string) (loc : int * int) -> + (fun (mt : 'module_type) _ (m : string) + (loc : Lexing.position * Lexing.position) -> (m, mt : 'module_rec_declaration))]]; Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None, [None, None, @@ -674,7 +704,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], Gramext.action - (fun (me : 'module_expr) _ (i : 'mod_ident) _ (loc : int * int) -> + (fun (me : 'module_expr) _ (i : 'mod_ident) _ + (loc : Lexing.position * Lexing.position) -> (MLast.WcMod (loc, i, me) : 'with_constr)); [Gramext.Stoken ("", "type"); Gramext.Snterm @@ -687,17 +718,31 @@ Grammar.extend 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) -> + (loc : Lexing.position * Lexing.position) -> (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 ("", "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 : Lexing.position * Lexing.position) -> + (MLast.ExObj (loc, cspo, cf) : 'expr)); + [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) -> + (fun _ (seq : 'sequence) _ _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExWhi (loc, e, seq) : 'expr)); [Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", "="); Gramext.Sself; @@ -710,25 +755,29 @@ Grammar.extend Gramext.Stoken ("", "}")], Gramext.action (fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : string) _ (loc : int * int) -> + (e1 : 'expr) _ (i : string) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (seq : 'sequence) _ _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExTry (loc, e, [p1, None, e1]) : 'expr)); [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); Gramext.Stoken ("", "["); @@ -738,14 +787,16 @@ Grammar.extend Gramext.Stoken ("", "|")); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (l : 'match_case list) _ _ (e : 'expr) _ (loc : int * int) -> + (fun _ (l : 'match_case list) _ _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExMat (loc, e, [p1, None, e1]) : 'expr)); [Gramext.Stoken ("", "match"); Gramext.Sself; Gramext.Stoken ("", "with"); Gramext.Stoken ("", "["); @@ -755,14 +806,16 @@ Grammar.extend Gramext.Stoken ("", "|")); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (l : 'match_case list) _ _ (e : 'expr) _ (loc : int * int) -> + (fun _ (l : 'match_case list) _ _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'fun_def) (p : 'ipatt) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExFun (loc, [p, None, e]) : 'expr)); [Gramext.Stoken ("", "fun"); Gramext.Stoken ("", "["); Gramext.Slist0sep @@ -771,7 +824,8 @@ Grammar.extend Gramext.Stoken ("", "|")); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (l : 'match_case list) _ _ (loc : int * int) -> + (fun _ (l : 'match_case list) _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExFun (loc, l) : 'expr)); [Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", ""); @@ -781,7 +835,7 @@ Grammar.extend Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action (fun (e : 'expr) _ (mb : 'module_binding) (m : string) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.ExLmd (loc, m, mb, e) : 'expr)); [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); Gramext.Slist1sep @@ -791,7 +845,7 @@ Grammar.extend Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action (fun (x : 'expr) _ (l : 'let_binding list) (r : string option) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.ExLet (loc, o2b r, l, x) : 'expr))]; Some "where", None, [[Gramext.Sself; Gramext.Stoken ("", "where"); @@ -800,252 +854,293 @@ Grammar.extend (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))], Gramext.action (fun (lb : 'let_binding) (rf : string option) _ (e : 'expr) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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)); + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (mkumin loc "-." e : 'expr)); [Gramext.Stoken ("", "-"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (mkumin loc "-" e : 'expr))]; + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (mkumin loc "-" e : 'expr))]; Some "apply", Some Gramext.LeftA, [[Gramext.Stoken ("", "lazy"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (MLast.ExLaz (loc, e) : 'expr)); [Gramext.Stoken ("", "assert"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (mkassert loc e : 'expr)); + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (mkassert loc e : 'expr)); [Gramext.Sself; Gramext.Sself], Gramext.action - (fun (e2 : 'expr) (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (e2 : 'expr) _ _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (e2 : 'expr) _ _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (MLast.ExAre (loc, e1, e2) : 'expr))]; Some "~-", Some Gramext.NonA, [[Gramext.Stoken ("", "~-."); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (MLast.ExApp (loc, MLast.ExLid (loc, "~-."), e) : 'expr)); [Gramext.Stoken ("", "~-"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (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.action + (fun _ (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ (el : 'expr list) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (t : 'ctyp) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExTyc (loc, e, t) : 'expr)); [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], Gramext.action - (fun _ _ (loc : int * int) -> (MLast.ExUid (loc, "()") : 'expr)); + (fun _ _ (loc : Lexing.position * Lexing.position) -> + (MLast.ExUid (loc, "()") : 'expr)); [Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with"); Gramext.Slist1sep @@ -1055,7 +1150,7 @@ Grammar.extend Gramext.Stoken ("", "}")], Gramext.action (fun _ (lel : 'label_expr list) _ _ (e : 'expr) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.ExRec (loc, lel, Some e) : 'expr)); [Gramext.Stoken ("", "{"); Gramext.Slist1sep @@ -1064,7 +1159,8 @@ Grammar.extend Gramext.Stoken ("", ";")); Gramext.Stoken ("", "}")], Gramext.action - (fun _ (lel : 'label_expr list) _ (loc : int * int) -> + (fun _ (lel : 'label_expr list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExRec (loc, lel, None) : 'expr)); [Gramext.Stoken ("", "[|"); Gramext.Slist0sep @@ -1072,7 +1168,8 @@ Grammar.extend Gramext.Stoken ("", ";")); Gramext.Stoken ("", "|]")], Gramext.action - (fun _ (el : 'expr list) _ (loc : int * int) -> + (fun _ (el : 'expr list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExArr (loc, el) : 'expr)); [Gramext.Stoken ("", "["); Gramext.Slist1sep @@ -1083,64 +1180,77 @@ Grammar.extend Gramext.Stoken ("", "]")], Gramext.action (fun _ (last : 'cons_expr_opt) (el : 'expr list) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (mklistexp loc last el : 'expr)); [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], Gramext.action - (fun _ _ (loc : int * int) -> (MLast.ExUid (loc, "[]") : 'expr)); + (fun _ _ (loc : Lexing.position * Lexing.position) -> + (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.action + (fun (i : 'expr_ident) (loc : Lexing.position * Lexing.position) -> + (i : 'expr)); [Gramext.Stoken ("CHAR", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExChr (loc, s) : 'expr)); [Gramext.Stoken ("STRING", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExStr (loc, s) : 'expr)); [Gramext.Stoken ("FLOAT", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExFlo (loc, s) : 'expr)); [Gramext.Stoken ("NATIVEINT", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExNativeInt (loc, s) : 'expr)); [Gramext.Stoken ("INT64", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExInt64 (loc, s) : 'expr)); [Gramext.Stoken ("INT32", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExInt32 (loc, s) : 'expr)); [Gramext.Stoken ("INT", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (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.action + (fun (loc : Lexing.position * Lexing.position) -> + (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))]]; + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (Some e : 'cons_expr_opt))]]; Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None, [None, None, - [[], Gramext.action (fun (loc : int * int) -> (() : 'dummy))]]; + [[], + Gramext.action + (fun (loc : Lexing.position * Lexing.position) -> (() : '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.action + (fun (e : 'expr) (loc : Lexing.position * Lexing.position) -> + ([e] : 'sequence)); [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> ([e] : 'sequence)); + (fun _ (e : 'expr) (loc : Lexing.position * Lexing.position) -> + ([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) -> + (fun (el : 'sequence) _ (e : 'expr) + (loc : Lexing.position * Lexing.position) -> (e :: el : 'sequence)); [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); Gramext.Slist1sep @@ -1149,13 +1259,17 @@ Grammar.extend Gramext.Stoken ("", "and")); Gramext.srules [[Gramext.Stoken ("", ";")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5)); + Gramext.action + (fun (x : string) (loc : Lexing.position * Lexing.position) -> + (x : 'e__5)); [Gramext.Stoken ("", "in")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5))]; + Gramext.action + (fun (x : string) (loc : Lexing.position * Lexing.position) -> + (x : 'e__5))]; Gramext.Sself], Gramext.action (fun (el : 'sequence) _ (l : 'let_binding list) (rf : string option) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> ([MLast.ExLet (loc, o2b rf, l, mksequence loc el)] : 'sequence))]]; Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None, [None, None, @@ -1163,7 +1277,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) -> + (fun (e : 'fun_binding) (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (p, e : 'let_binding))]]; Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None, [None, Some Gramext.RightA, @@ -1172,16 +1287,19 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> + (fun (e : 'expr) _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (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)); + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (e : 'fun_binding) (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (MLast.ExFun (loc, [p, None, e]) : 'fun_binding))]]; Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e), None, [None, None, @@ -1194,22 +1312,30 @@ Grammar.extend 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) -> + (p : 'patt) (loc : Lexing.position * Lexing.position) -> (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.action + (fun (loc : Lexing.position * Lexing.position) -> + (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))]]; + (fun (p : 'patt) _ (loc : Lexing.position * Lexing.position) -> + (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.action + (fun (loc : Lexing.position * Lexing.position) -> + (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))]]; + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (Some e : 'when_expr_opt))]]; Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None, [None, None, [[Gramext.Snterm @@ -1218,81 +1344,98 @@ Grammar.extend 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) -> + (fun (e : 'fun_binding) (i : 'patt_label_ident) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (j : 'expr_ident) _ (i : string) + (loc : Lexing.position * Lexing.position) -> (mkexprident loc i j : 'expr_ident)); [Gramext.Stoken ("UIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExUid (loc, i) : 'expr_ident)); [Gramext.Stoken ("LIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (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.action + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (e : 'fun_def) (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (p2 : 'patt) _ (p1 : 'patt) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (p2 : 'patt) _ (p1 : 'patt) + (loc : Lexing.position * Lexing.position) -> (MLast.PaRng (loc, p1, p2) : 'patt))]; None, Some Gramext.LeftA, [[Gramext.Sself; Gramext.Sself], Gramext.action - (fun (p2 : 'patt) (p1 : 'patt) (loc : int * int) -> + (fun (p2 : 'patt) (p1 : 'patt) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (p2 : 'patt) _ (p1 : 'patt) + (loc : Lexing.position * Lexing.position) -> (MLast.PaAcc (loc, p1, p2) : 'patt))]; Some "simple", None, [[Gramext.Stoken ("", "_")], - Gramext.action (fun _ (loc : int * int) -> (MLast.PaAny loc : 'patt)); + Gramext.action + (fun _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ (pl : 'patt list) _ (p : 'patt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (p2 : 'patt) _ (p : 'patt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (t : 'ctyp) _ (p : 'patt) _ + (loc : Lexing.position * Lexing.position) -> (MLast.PaTyc (loc, p, t) : 'patt)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'patt)); + Gramext.action + (fun _ (p : 'patt) _ (loc : Lexing.position * Lexing.position) -> + (p : 'patt)); [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], Gramext.action - (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "()") : 'patt)); + (fun _ _ (loc : Lexing.position * Lexing.position) -> + (MLast.PaUid (loc, "()") : 'patt)); [Gramext.Stoken ("", "{"); Gramext.Slist1sep (Gramext.Snterm @@ -1300,7 +1443,8 @@ Grammar.extend Gramext.Stoken ("", ";")); Gramext.Stoken ("", "}")], Gramext.action - (fun _ (lpl : 'label_patt list) _ (loc : int * int) -> + (fun _ (lpl : 'label_patt list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.PaRec (loc, lpl) : 'patt)); [Gramext.Stoken ("", "[|"); Gramext.Slist0sep @@ -1308,7 +1452,8 @@ Grammar.extend Gramext.Stoken ("", ";")); Gramext.Stoken ("", "|]")], Gramext.action - (fun _ (pl : 'patt list) _ (loc : int * int) -> + (fun _ (pl : 'patt list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.PaArr (loc, pl) : 'patt)); [Gramext.Stoken ("", "["); Gramext.Slist1sep @@ -1319,74 +1464,79 @@ Grammar.extend Gramext.Stoken ("", "]")], Gramext.action (fun _ (last : 'cons_patt_opt) (pl : 'patt list) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (mklistpat loc last pl : 'patt)); [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], Gramext.action - (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "[]") : 'patt)); + (fun _ _ (loc : Lexing.position * Lexing.position) -> + (MLast.PaUid (loc, "[]") : 'patt)); [Gramext.Stoken ("", "-"); Gramext.Stoken ("FLOAT", "")], Gramext.action - (fun (s : string) _ (loc : int * int) -> + (fun (s : string) _ (loc : Lexing.position * Lexing.position) -> (MLast.PaFlo (loc, neg_string s) : 'patt)); [Gramext.Stoken ("", "-"); Gramext.Stoken ("NATIVEINT", "")], Gramext.action - (fun (s : string) _ (loc : int * int) -> + (fun (s : string) _ (loc : Lexing.position * Lexing.position) -> (MLast.PaNativeInt (loc, neg_string s) : 'patt)); [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT64", "")], Gramext.action - (fun (s : string) _ (loc : int * int) -> + (fun (s : string) _ (loc : Lexing.position * Lexing.position) -> (MLast.PaInt64 (loc, neg_string s) : 'patt)); [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT32", "")], Gramext.action - (fun (s : string) _ (loc : int * int) -> + (fun (s : string) _ (loc : Lexing.position * Lexing.position) -> (MLast.PaInt32 (loc, neg_string s) : 'patt)); [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT", "")], Gramext.action - (fun (s : string) _ (loc : int * int) -> + (fun (s : string) _ (loc : Lexing.position * Lexing.position) -> (MLast.PaInt (loc, neg_string s) : 'patt)); [Gramext.Stoken ("CHAR", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaChr (loc, s) : 'patt)); [Gramext.Stoken ("STRING", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaStr (loc, s) : 'patt)); [Gramext.Stoken ("FLOAT", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaFlo (loc, s) : 'patt)); [Gramext.Stoken ("NATIVEINT", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaNativeInt (loc, s) : 'patt)); [Gramext.Stoken ("INT64", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaInt64 (loc, s) : 'patt)); [Gramext.Stoken ("INT32", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaInt32 (loc, s) : 'patt)); [Gramext.Stoken ("INT", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaInt (loc, s) : 'patt)); [Gramext.Stoken ("UIDENT", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaUid (loc, s) : 'patt)); [Gramext.Stoken ("LIDENT", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (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.action + (fun (loc : Lexing.position * Lexing.position) -> + (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))]]; + (fun (p : 'patt) _ (loc : Lexing.position * Lexing.position) -> + (Some p : 'cons_patt_opt))]]; Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None, [None, None, [[Gramext.Snterm @@ -1395,7 +1545,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], Gramext.action - (fun (p : 'patt) _ (i : 'patt_label_ident) (loc : int * int) -> + (fun (p : 'patt) _ (i : 'patt_label_ident) + (loc : Lexing.position * Lexing.position) -> (i, p : 'label_patt))]]; Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), None, @@ -1403,24 +1554,26 @@ Grammar.extend [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], Gramext.action (fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.PaAcc (loc, p1, p2) : 'patt_label_ident))]; Some "simple", Some Gramext.RightA, [[Gramext.Stoken ("LIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaLid (loc, i) : 'patt_label_ident)); [Gramext.Stoken ("UIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (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.action + (fun _ (loc : Lexing.position * Lexing.position) -> + (MLast.PaAny loc : 'ipatt)); [Gramext.Stoken ("LIDENT", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaLid (loc, s) : 'ipatt)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); Gramext.Slist1sep @@ -1428,24 +1581,30 @@ Grammar.extend Gramext.Stoken ("", ",")); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (pl : 'ipatt list) _ (p : 'ipatt) _ (loc : int * int) -> + (fun _ (pl : 'ipatt list) _ (p : 'ipatt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (t : 'ctyp) _ (p : 'ipatt) _ + (loc : Lexing.position * Lexing.position) -> (MLast.PaTyc (loc, p, t) : 'ipatt)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (p : 'ipatt) _ (loc : int * int) -> (p : 'ipatt)); + Gramext.action + (fun _ (p : 'ipatt) _ (loc : Lexing.position * Lexing.position) -> + (p : 'ipatt)); [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], Gramext.action - (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "()") : 'ipatt)); + (fun _ _ (loc : Lexing.position * Lexing.position) -> + (MLast.PaUid (loc, "()") : 'ipatt)); [Gramext.Stoken ("", "{"); Gramext.Slist1sep (Gramext.Snterm @@ -1453,7 +1612,8 @@ Grammar.extend Gramext.Stoken ("", ";")); Gramext.Stoken ("", "}")], Gramext.action - (fun _ (lpl : 'label_ipatt list) _ (loc : int * int) -> + (fun _ (lpl : 'label_ipatt list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.PaRec (loc, lpl) : 'ipatt))]]; Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None, [None, None, @@ -1463,7 +1623,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], Gramext.action - (fun (p : 'ipatt) _ (i : 'patt_label_ident) (loc : int * int) -> + (fun (p : 'ipatt) _ (i : 'patt_label_ident) + (loc : Lexing.position * Lexing.position) -> (i, p : 'label_ipatt))]]; Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e), None, @@ -1481,13 +1642,15 @@ Grammar.extend (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) -> + (tpl : 'type_parameter list) (n : 'type_patt) + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (n : string) (loc : Lexing.position * Lexing.position) -> + (loc, n : 'type_patt))]]; Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("", "constraint"); @@ -1495,7 +1658,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (t1, t2 : 'constrain))]]; Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e), None, @@ -1503,28 +1667,30 @@ Grammar.extend [[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'"); Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], Gramext.action - (fun (i : 'ident) _ _ (loc : int * int) -> + (fun (i : 'ident) _ _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'ident) _ _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (loc : Lexing.position * Lexing.position) -> (MLast.TyAli (loc, t1, t2) : 'ctyp))]; None, Some Gramext.LeftA, [[Gramext.Stoken ("", "!"); @@ -1533,41 +1699,49 @@ Grammar.extend (Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e))); Gramext.Stoken ("", "."); Gramext.Sself], Gramext.action - (fun (t : 'ctyp) _ (pl : 'typevar list) _ (loc : int * int) -> + (fun (t : 'ctyp) _ (pl : 'typevar list) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (loc : Lexing.position * Lexing.position) -> (MLast.TyArr (loc, t1, t2) : 'ctyp))]; Some "label", Some Gramext.NonA, [[Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself], Gramext.action - (fun (t : 'ctyp) (i : string) (loc : int * int) -> + (fun (t : 'ctyp) (i : string) + (loc : Lexing.position * Lexing.position) -> (MLast.TyOlb (loc, i, t) : 'ctyp)); [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> + (fun (t : 'ctyp) _ (i : string) + (loc : Lexing.position * Lexing.position) -> (MLast.TyOlb (loc, i, t) : 'ctyp)); [Gramext.Stoken ("LABEL", ""); Gramext.Sself], Gramext.action - (fun (t : 'ctyp) (i : string) (loc : int * int) -> + (fun (t : 'ctyp) (i : string) + (loc : Lexing.position * Lexing.position) -> (MLast.TyLab (loc, i, t) : 'ctyp)); [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> + (fun (t : 'ctyp) _ (i : string) + (loc : Lexing.position * Lexing.position) -> (MLast.TyLab (loc, i, t) : 'ctyp))]; None, Some Gramext.LeftA, [[Gramext.Sself; Gramext.Sself], Gramext.action - (fun (t2 : 'ctyp) (t1 : 'ctyp) (loc : int * int) -> + (fun (t2 : 'ctyp) (t1 : 'ctyp) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (loc : Lexing.position * Lexing.position) -> (MLast.TyAcc (loc, t1, t2) : 'ctyp))]; Some "simple", None, [[Gramext.Stoken ("", "{"); @@ -1578,7 +1752,8 @@ Grammar.extend Gramext.Stoken ("", ";")); Gramext.Stoken ("", "}")], Gramext.action - (fun _ (ldl : 'label_declaration list) _ (loc : int * int) -> + (fun _ (ldl : 'label_declaration list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.TyRec (loc, false, ldl) : 'ctyp)); [Gramext.Stoken ("", "["); Gramext.Slist0sep @@ -1589,7 +1764,8 @@ Grammar.extend Gramext.Stoken ("", "|")); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (cdl : 'constructor_declaration list) _ (loc : int * int) -> + (fun _ (cdl : 'constructor_declaration list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.TySum (loc, false, cdl) : 'ctyp)); [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "{"); Gramext.Slist1sep @@ -1599,7 +1775,8 @@ Grammar.extend Gramext.Stoken ("", ";")); Gramext.Stoken ("", "}")], Gramext.action - (fun _ (ldl : 'label_declaration list) _ _ (loc : int * int) -> + (fun _ (ldl : 'label_declaration list) _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.TyRec (loc, true, ldl) : 'ctyp)); [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "["); Gramext.Slist0sep @@ -1610,32 +1787,38 @@ Grammar.extend Gramext.Stoken ("", "|")); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (cdl : 'constructor_declaration list) _ _ (loc : int * int) -> + (fun _ (cdl : 'constructor_declaration list) _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.TySum (loc, true, cdl) : 'ctyp)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'ctyp)); + Gramext.action + (fun _ (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ (tl : 'ctyp list) _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (MLast.TyTup (loc, (t :: tl)) : 'ctyp)); [Gramext.Stoken ("UIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.TyUid (loc, i) : 'ctyp)); [Gramext.Stoken ("LIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.TyLid (loc, i) : 'ctyp)); [Gramext.Stoken ("", "_")], - Gramext.action (fun _ (loc : int * int) -> (MLast.TyAny loc : 'ctyp)); + Gramext.action + (fun _ (loc : Lexing.position * Lexing.position) -> + (MLast.TyAny loc : 'ctyp)); [Gramext.Stoken ("", "'"); Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> (MLast.TyQuo (loc, i) : 'ctyp))]]; Grammar.Entry.obj (constructor_declaration : 'constructor_declaration Grammar.Entry.e), @@ -1643,14 +1826,15 @@ Grammar.extend [None, None, [[Gramext.Stoken ("UIDENT", "")], Gramext.action - (fun (ci : string) (loc : int * int) -> + (fun (ci : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (cal : 'ctyp list) _ (ci : string) + (loc : Lexing.position * Lexing.position) -> (loc, ci, cal : 'constructor_declaration))]]; Grammar.Entry.obj (label_declaration : 'label_declaration Grammar.Entry.e), @@ -1661,27 +1845,34 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action (fun (t : 'ctyp) (mf : string option) _ (i : string) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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.action + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + (i : 'ident)); [Gramext.Stoken ("LIDENT", "")], - Gramext.action (fun (i : string) (loc : int * int) -> (i : 'ident))]]; + Gramext.action + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (j : 'mod_ident) _ (i : string) + (loc : Lexing.position * Lexing.position) -> (i :: j : 'mod_ident)); [Gramext.Stoken ("LIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> ([i] : 'mod_ident)); + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + ([i] : 'mod_ident)); [Gramext.Stoken ("UIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> ([i] : 'mod_ident))]]; + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + ([i] : 'mod_ident))]]; Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); @@ -1692,7 +1883,8 @@ Grammar.extend 'class_type_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (ctd : 'class_type_declaration list) _ _ (loc : int * int) -> + (fun (ctd : 'class_type_declaration list) _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.StClt (loc, ctd) : 'str_item)); [Gramext.Stoken ("", "class"); Gramext.Slist1sep @@ -1701,7 +1893,8 @@ Grammar.extend (class_declaration : 'class_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (cd : 'class_declaration list) _ (loc : int * int) -> + (fun (cd : 'class_declaration list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.StCls (loc, cd) : 'str_item))]]; Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, [None, None, @@ -1713,7 +1906,8 @@ Grammar.extend 'class_type_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (ctd : 'class_type_declaration list) _ _ (loc : int * int) -> + (fun (ctd : 'class_type_declaration list) _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.SgClt (loc, ctd) : 'sig_item)); [Gramext.Stoken ("", "class"); Gramext.Slist1sep @@ -1722,7 +1916,8 @@ Grammar.extend (class_description : 'class_description Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (cd : 'class_description list) _ (loc : int * int) -> + (fun (cd : 'class_description list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.SgCls (loc, cd) : 'sig_item))]]; Grammar.Entry.obj (class_declaration : 'class_declaration Grammar.Entry.e), @@ -1738,7 +1933,8 @@ Grammar.extend (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) -> + (i : string) (vf : string option) + (loc : Lexing.position * Lexing.position) -> ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = i; MLast.ciExp = cfb} : 'class_declaration))]]; @@ -1749,7 +1945,8 @@ Grammar.extend [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); Gramext.Sself], Gramext.action - (fun (cfb : 'class_fun_binding) (p : 'ipatt) (loc : int * int) -> + (fun (cfb : 'class_fun_binding) (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (MLast.CeFun (loc, p, cfb) : 'class_fun_binding)); [Gramext.Stoken ("", ":"); Gramext.Snterm @@ -1758,13 +1955,14 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], Gramext.action - (fun (ce : 'class_expr) _ (ct : 'class_type) _ (loc : int * int) -> + (fun (ce : 'class_expr) _ (ct : 'class_type) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (ce : 'class_expr) _ (loc : Lexing.position * Lexing.position) -> (ce : 'class_fun_binding))]]; Grammar.Entry.obj (class_type_parameters : 'class_type_parameters Grammar.Entry.e), @@ -1778,22 +1976,26 @@ Grammar.extend Gramext.Stoken ("", ",")); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (tpl : 'type_parameter list) _ (loc : int * int) -> + (fun _ (tpl : 'type_parameter list) _ + (loc : Lexing.position * Lexing.position) -> (loc, tpl : 'class_type_parameters)); [], Gramext.action - (fun (loc : int * int) -> (loc, [] : 'class_type_parameters))]]; + (fun (loc : Lexing.position * Lexing.position) -> + (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)); + (fun (ce : 'class_expr) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (ce : 'class_fun_def) (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (MLast.CeFun (loc, p, ce) : 'class_fun_def))]]; Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None, [Some "top", None, @@ -1805,7 +2007,7 @@ Grammar.extend Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action (fun (ce : 'class_expr) _ (lb : 'let_binding list) - (rf : string option) _ (loc : int * int) -> + (rf : string option) _ (loc : Lexing.position * Lexing.position) -> (MLast.CeLet (loc, o2b rf, lb, ce) : 'class_expr)); [Gramext.Stoken ("", "fun"); Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); @@ -1813,25 +2015,30 @@ Grammar.extend (Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e))], Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) _ (loc : int * int) -> + (fun (ce : 'class_fun_def) (p : 'ipatt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'expr) (ce : 'class_expr) + (loc : Lexing.position * Lexing.position) -> (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)); + (fun _ (ce : 'class_expr) _ + (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ + (loc : Lexing.position * Lexing.position) -> (MLast.CeTyc (loc, ce, ct) : 'class_expr)); [Gramext.Stoken ("", "object"); Gramext.Sopt @@ -1844,13 +2051,14 @@ Grammar.extend Gramext.Stoken ("", "end")], Gramext.action (fun _ (cf : 'class_structure) (cspo : 'class_self_patt option) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (ci : 'class_longident) + (loc : Lexing.position * Lexing.position) -> (MLast.CeCon (loc, ci, []) : 'class_expr)); [Gramext.Snterm (Grammar.Entry.obj @@ -1862,7 +2070,7 @@ Grammar.extend Gramext.Stoken ("", "]")], Gramext.action (fun _ (ctcl : 'ctyp list) _ (ci : 'class_longident) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.CeCon (loc, ci, ctcl) : 'class_expr))]]; Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e), None, @@ -1874,10 +2082,11 @@ Grammar.extend (class_str_item : 'class_str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (cf : 'class_str_item) (loc : int * int) -> + (fun _ (cf : 'class_str_item) + (loc : Lexing.position * Lexing.position) -> (cf : 'e__6))])], Gramext.action - (fun (cf : 'e__6 list) (loc : int * int) -> + (fun (cf : 'e__6 list) (loc : Lexing.position * Lexing.position) -> (cf : 'class_structure))]]; Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e), None, @@ -1888,27 +2097,30 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> + (fun _ (t : 'ctyp) _ (p : 'patt) _ + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun _ (p : 'patt) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (se : 'expr) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (MLast.CrCtr (loc, t1, t2) : 'class_str_item)); [Gramext.Stoken ("", "method"); Gramext.Sopt (Gramext.Stoken ("", "private")); @@ -1920,7 +2132,7 @@ Grammar.extend (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) -> + (pf : string option) _ (loc : Lexing.position * Lexing.position) -> (MLast.CrMth (loc, l, o2b pf, e, topt) : 'class_str_item)); [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); Gramext.Sopt (Gramext.Stoken ("", "private")); @@ -1929,7 +2141,7 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.CrVir (loc, l, o2b pf, t) : 'class_str_item)); [Gramext.Stoken ("", "value"); Gramext.Sopt (Gramext.Stoken ("", "mutable")); @@ -1939,7 +2151,7 @@ Grammar.extend (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], Gramext.action (fun (e : 'cvalue_binding) (lab : 'label) (mf : string option) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.CrVal (loc, lab, o2b mf, e) : 'class_str_item)); [Gramext.Stoken ("", "inherit"); Gramext.Snterm @@ -1949,7 +2161,7 @@ Grammar.extend (Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e)))], Gramext.action (fun (pb : 'as_lident option) (ce : 'class_expr) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.CrInh (loc, ce, pb) : 'class_str_item)); [Gramext.Stoken ("", "declare"); Gramext.Slist0 @@ -1959,22 +2171,27 @@ Grammar.extend (class_str_item : 'class_str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'class_str_item) (loc : int * int) -> + (fun _ (s : 'class_str_item) + (loc : Lexing.position * Lexing.position) -> (s : 'e__7))]); Gramext.Stoken ("", "end")], Gramext.action - (fun _ (st : 'e__7 list) _ (loc : int * int) -> + (fun _ (st : 'e__7 list) _ + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (i : string) _ (loc : Lexing.position * Lexing.position) -> + (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))]]; + Gramext.action + (fun (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) -> + (t : 'polyt))]]; Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e), None, [None, None, @@ -1983,7 +2200,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> + (fun (e : 'expr) _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExCoe (loc, e, None, t) : 'cvalue_binding)); [Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); @@ -1992,23 +2210,28 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (loc : int * int) -> + (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'expr) _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (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))]]; + Gramext.action + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + (i : 'label))]]; Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("", "object"); @@ -2023,18 +2246,20 @@ Grammar.extend (class_sig_item : 'class_sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> + (fun _ (csf : 'class_sig_item) + (loc : Lexing.position * Lexing.position) -> (csf : 'e__8))]); Gramext.Stoken ("", "end")], Gramext.action (fun _ (csf : 'e__8 list) (cst : 'class_self_type option) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (id : 'clty_longident) + (loc : Lexing.position * Lexing.position) -> (MLast.CtCon (loc, id, []) : 'class_type)); [Gramext.Snterm (Grammar.Entry.obj @@ -2045,13 +2270,15 @@ Grammar.extend Gramext.Stoken ("", ",")); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (tl : 'ctyp list) _ (id : 'clty_longident) (loc : int * int) -> + (fun _ (tl : 'ctyp list) _ (id : 'clty_longident) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (ct : 'class_type) _ _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (MLast.CtFun (loc, t, ct) : 'class_type))]]; Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e), None, @@ -2060,7 +2287,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'class_self_type))]]; + (fun _ (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) -> + (t : 'class_self_type))]]; Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), None, [None, None, @@ -2069,7 +2297,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (MLast.CgCtr (loc, t1, t2) : 'class_sig_item)); [Gramext.Stoken ("", "method"); Gramext.Sopt (Gramext.Stoken ("", "private")); @@ -2078,7 +2307,7 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.CgMth (loc, l, o2b pf, t) : 'class_sig_item)); [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); Gramext.Sopt (Gramext.Stoken ("", "private")); @@ -2087,7 +2316,7 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.CgVir (loc, l, o2b pf, t) : 'class_sig_item)); [Gramext.Stoken ("", "value"); Gramext.Sopt (Gramext.Stoken ("", "mutable")); @@ -2096,13 +2325,13 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (cs : 'class_type) _ (loc : Lexing.position * Lexing.position) -> (MLast.CgInh (loc, cs) : 'class_sig_item)); [Gramext.Stoken ("", "declare"); Gramext.Slist0 @@ -2112,11 +2341,13 @@ Grammar.extend (class_sig_item : 'class_sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'class_sig_item) (loc : int * int) -> + (fun _ (s : 'class_sig_item) + (loc : Lexing.position * Lexing.position) -> (s : 'e__9))]); Gramext.Stoken ("", "end")], Gramext.action - (fun _ (st : 'e__9 list) _ (loc : int * int) -> + (fun _ (st : 'e__9 list) _ + (loc : Lexing.position * Lexing.position) -> (MLast.CgDcl (loc, st) : 'class_sig_item))]]; Grammar.Entry.obj (class_description : 'class_description Grammar.Entry.e), @@ -2132,7 +2363,7 @@ Grammar.extend (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) -> + (vf : string option) (loc : Lexing.position * Lexing.position) -> ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = n; MLast.ciExp = ct} : 'class_description))]]; @@ -2150,7 +2381,7 @@ Grammar.extend (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) -> + (vf : string option) (loc : Lexing.position * Lexing.position) -> ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = n; MLast.ciExp = cs} : 'class_type_declaration))]]; @@ -2162,7 +2393,8 @@ Grammar.extend (Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e))], Gramext.action - (fun (i : 'class_longident) _ (loc : int * int) -> + (fun (i : 'class_longident) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExNew (loc, i) : 'expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "."), @@ -2170,7 +2402,8 @@ Grammar.extend [[Gramext.Sself; Gramext.Stoken ("", "#"); Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))], Gramext.action - (fun (lab : 'label) _ (e : 'expr) (loc : int * int) -> + (fun (lab : 'label) _ (e : 'expr) + (loc : Lexing.position * Lexing.position) -> (MLast.ExSnd (loc, e, lab) : 'expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -2182,13 +2415,15 @@ Grammar.extend Gramext.Stoken ("", ";")); Gramext.Stoken ("", ">}")], Gramext.action - (fun _ (fel : 'field_expr list) _ (loc : int * int) -> + (fun _ (fel : 'field_expr list) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (t : 'ctyp) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExCoe (loc, e, None, t) : 'expr)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); @@ -2196,7 +2431,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> + (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExCoe (loc, e, Some t, t2) : 'expr))]]; Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None, [None, None, @@ -2204,65 +2440,120 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (l : 'label) (loc : int * int) -> + (fun (e : 'expr) _ (l : 'label) + (loc : Lexing.position * Lexing.position) -> (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.Stoken ("", "<"); Gramext.Stoken ("", ">")], + Gramext.action + (fun _ _ (loc : Lexing.position * Lexing.position) -> + (MLast.TyObj (loc, [], false) : 'ctyp)); + [Gramext.Stoken ("", "<"); + Gramext.Snterm + (Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e)); + Gramext.Stoken ("", ">")], Gramext.action - (fun _ (v : string option) (ml : 'field list) _ (loc : int * int) -> - (MLast.TyObj (loc, ml, o2b v) : 'ctyp)); + (fun _ (ml, v : 'meth_list) _ + (loc : Lexing.position * Lexing.position) -> + (MLast.TyObj (loc, ml, 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) -> + (fun (id : 'class_longident) _ + (loc : Lexing.position * Lexing.position) -> (MLast.TyCls (loc, id) : 'ctyp))]]; + Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("", "..")], + Gramext.action + (fun _ (loc : Lexing.position * Lexing.position) -> + ([], true : 'meth_list)); + [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e))], + Gramext.action + (fun (f : 'field) (loc : Lexing.position * Lexing.position) -> + ([f], false : 'meth_list)); + [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)); + Gramext.Stoken ("", ";")], + Gramext.action + (fun _ (f : 'field) (loc : Lexing.position * Lexing.position) -> + ([f], false : 'meth_list)); + [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)); + Gramext.Stoken ("", ";"); Gramext.Sself], + Gramext.action + (fun (ml, v : 'meth_list) _ (f : 'field) + (loc : Lexing.position * Lexing.position) -> + (f :: ml, v : 'meth_list))]]; 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) -> + (fun (t : 'ctyp) _ (lab : string) + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> + (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)); + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + ([i] : 'clty_longident)); [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); Gramext.Sself], Gramext.action - (fun (l : 'clty_longident) _ (m : string) (loc : int * int) -> + (fun (l : 'clty_longident) _ (m : string) + (loc : Lexing.position * Lexing.position) -> (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)); + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + ([i] : 'class_longident)); [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); Gramext.Sself], Gramext.action - (fun (l : 'class_longident) _ (m : string) (loc : int * int) -> + (fun (l : 'class_longident) _ (m : string) + (loc : Lexing.position * Lexing.position) -> (m :: l : 'class_longident))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, - [[Gramext.Stoken ("", "["); 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 : Lexing.position * Lexing.position) -> + (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp)); + [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 : Lexing.position * Lexing.position) -> + (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)); @@ -2273,7 +2564,7 @@ Grammar.extend Gramext.Stoken ("", "]")], Gramext.action (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp)); [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); Gramext.Snterm @@ -2281,7 +2572,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp)); [Gramext.Stoken ("", "["); Gramext.Stoken ("", ">"); Gramext.Snterm @@ -2289,7 +2581,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.TyVrn (loc, rfl, Some None) : 'ctyp)); [Gramext.Stoken ("", "["); Gramext.Stoken ("", "="); Gramext.Snterm @@ -2297,7 +2590,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.TyVrn (loc, rfl, None) : 'ctyp))]]; Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e), None, @@ -2307,13 +2601,15 @@ Grammar.extend (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)), Gramext.Stoken ("", "|"))], Gramext.action - (fun (rfl : 'row_field list) (loc : int * int) -> + (fun (rfl : 'row_field list) + (loc : Lexing.position * Lexing.position) -> (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)); + (fun (t : 'ctyp) (loc : Lexing.position * Lexing.position) -> + (MLast.RfInh t : 'row_field)); [Gramext.Stoken ("", "`"); Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e)); Gramext.Stoken ("", "of"); Gramext.Sopt (Gramext.Stoken ("", "&")); @@ -2322,19 +2618,20 @@ Grammar.extend Gramext.Stoken ("", "&"))], Gramext.action (fun (l : 'ctyp list) (ao : string option) _ (i : 'ident) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> + (i : 'name_tag))]]; Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, @@ -2347,11 +2644,11 @@ Grammar.extend Gramext.Stoken ("", ")")], Gramext.action (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.PaOlb (loc, "", Some (p, eo)) : 'patt)); [Gramext.Stoken ("QUESTIONIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaOlb (loc, i, None) : 'patt)); [Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "("); Gramext.Snterm @@ -2362,7 +2659,7 @@ Grammar.extend Gramext.Stoken ("", ")")], Gramext.action (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ (i : string) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt)); [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); @@ -2374,41 +2671,46 @@ Grammar.extend Gramext.Stoken ("", ")")], Gramext.action (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ (i : string) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt)); [Gramext.Stoken ("TILDEIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaLab (loc, i, None) : 'patt)); [Gramext.Stoken ("LABEL", ""); Gramext.Sself], Gramext.action - (fun (p : 'patt) (i : string) (loc : int * int) -> + (fun (p : 'patt) (i : string) + (loc : Lexing.position * Lexing.position) -> (MLast.PaLab (loc, i, Some p) : 'patt)); [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (p : 'patt) _ (i : string) (loc : int * int) -> + (fun (p : 'patt) _ (i : string) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (sl : 'mod_ident) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'ident) _ (loc : Lexing.position * Lexing.position) -> (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.action + (fun (p : 'patt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (t : 'ctyp) _ (p : 'patt) + (loc : Lexing.position * Lexing.position) -> (MLast.PaTyc (loc, p, t) : 'patt_tcon))]]; Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, [None, None, @@ -2421,11 +2723,11 @@ Grammar.extend Gramext.Stoken ("", ")")], Gramext.action (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.PaOlb (loc, "", Some (p, eo)) : 'ipatt)); [Gramext.Stoken ("QUESTIONIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaOlb (loc, i, None) : 'ipatt)); [Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "("); Gramext.Snterm @@ -2436,7 +2738,7 @@ Grammar.extend Gramext.Stoken ("", ")")], Gramext.action (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ (i : string) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt)); [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); @@ -2448,66 +2750,75 @@ Grammar.extend Gramext.Stoken ("", ")")], Gramext.action (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ (i : string) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt)); [Gramext.Stoken ("TILDEIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaLab (loc, i, None) : 'ipatt)); [Gramext.Stoken ("LABEL", ""); Gramext.Sself], Gramext.action - (fun (p : 'ipatt) (i : string) (loc : int * int) -> + (fun (p : 'ipatt) (i : string) + (loc : Lexing.position * Lexing.position) -> (MLast.PaLab (loc, i, Some p) : 'ipatt)); [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (p : 'ipatt) _ (i : string) (loc : int * int) -> + (fun (p : 'ipatt) _ (i : string) + (loc : Lexing.position * Lexing.position) -> (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)); + (fun (p : 'ipatt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (t : 'ctyp) _ (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExOlb (loc, i, None) : 'expr)); [Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself], Gramext.action - (fun (e : 'expr) (i : string) (loc : int * int) -> + (fun (e : 'expr) (i : string) + (loc : Lexing.position * Lexing.position) -> (MLast.ExOlb (loc, i, Some e) : 'expr)); [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (i : string) (loc : int * int) -> + (fun (e : 'expr) _ (i : string) + (loc : Lexing.position * Lexing.position) -> (MLast.ExOlb (loc, i, Some e) : 'expr)); [Gramext.Stoken ("TILDEIDENT", "")], Gramext.action - (fun (i : string) (loc : int * int) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.ExLab (loc, i, None) : 'expr)); [Gramext.Stoken ("LABEL", ""); Gramext.Sself], Gramext.action - (fun (e : 'expr) (i : string) (loc : int * int) -> + (fun (e : 'expr) (i : string) + (loc : Lexing.position * Lexing.position) -> (MLast.ExLab (loc, i, Some e) : 'expr)); [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (i : string) (loc : int * int) -> + (fun (e : 'expr) _ (i : string) + (loc : Lexing.position * Lexing.position) -> (MLast.ExLab (loc, i, Some e) : 'expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -2515,15 +2826,19 @@ Grammar.extend [[Gramext.Stoken ("", "`"); Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], Gramext.action - (fun (s : 'ident) _ (loc : int * int) -> + (fun (s : 'ident) _ (loc : Lexing.position * Lexing.position) -> (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.action + (fun _ (loc : Lexing.position * Lexing.position) -> + (false : 'direction_flag)); [Gramext.Stoken ("", "to")], - Gramext.action (fun _ (loc : int * int) -> (true : 'direction_flag))]]; + Gramext.action + (fun _ (loc : Lexing.position * Lexing.position) -> + (true : 'direction_flag))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, @@ -2542,7 +2857,7 @@ Grammar.extend Gramext.Stoken ("", "|]")], Gramext.action (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp)); [Gramext.Stoken ("", "[|"); Gramext.Snterm @@ -2554,7 +2869,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "|]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp)); [Gramext.Stoken ("", "[|"); Gramext.Snterm @@ -2566,7 +2882,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "|]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ _ + (loc : Lexing.position * Lexing.position) -> (MLast.TyVrn (loc, rfl, Some None) : 'ctyp)); [Gramext.Stoken ("", "[|"); Gramext.Snterm @@ -2577,14 +2894,16 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "|]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (loc : Lexing.position * Lexing.position) -> + (warn_variant loc : 'warning_variant))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "top"), [None, None, @@ -2595,13 +2914,15 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__12))]); + (fun _ (e : 'expr) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ _ (seq : 'e__12 list) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExWhi (loc, e, seq) : 'expr)); [Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", "="); Gramext.Sself; @@ -2615,14 +2936,16 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__11))]); + (fun _ (e : 'expr) (loc : Lexing.position * Lexing.position) -> + (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) -> + (e1 : 'expr) _ (i : string) _ + (loc : Lexing.position * Lexing.position) -> (MLast.ExFor (loc, i, e1, e2, df, seq) : 'expr)); [Gramext.Stoken ("", "do"); Gramext.Slist0 @@ -2631,21 +2954,23 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__10))]); + (fun _ (e : 'expr) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (e : 'expr) _ _ (seq : 'e__10 list) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (loc : Lexing.position * Lexing.position) -> (warn_sequence loc : 'warning_sequence))]]]);; Grammar.extend @@ -2666,20 +2991,23 @@ Grammar.extend [Grammar.Entry.obj (interf : 'interf Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("EOI", "")], - Gramext.action (fun _ (loc : int * int) -> ([], false : 'interf)); + Gramext.action + (fun _ (loc : Lexing.position * Lexing.position) -> + ([], 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) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (dp : 'expr option) (n : string) _ + (loc : Lexing.position * Lexing.position) -> ([MLast.SgDir (loc, n, dp), loc], true : 'interf))]]; Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e), None, [None, None, @@ -2687,25 +3015,28 @@ Grammar.extend (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (si : 'sig_item) (loc : int * int) -> + (fun _ (si : 'sig_item) (loc : Lexing.position * Lexing.position) -> (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.action + (fun _ (loc : Lexing.position * Lexing.position) -> + ([], 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) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (dp : 'expr option) (n : string) _ + (loc : Lexing.position * Lexing.position) -> ([MLast.StDir (loc, n, dp), loc], true : 'implem))]]; Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e), None, [None, None, @@ -2713,32 +3044,38 @@ Grammar.extend (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (si : 'str_item) (loc : int * int) -> + (fun _ (si : 'str_item) (loc : Lexing.position * Lexing.position) -> (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.action + (fun _ (loc : Lexing.position * Lexing.position) -> + (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))]]; + (fun (ph : 'phrase) (loc : Lexing.position * Lexing.position) -> + (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.action + (fun _ (loc : Lexing.position * Lexing.position) -> + ([], 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) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (dp : 'expr option) (n : string) _ + (loc : Lexing.position * Lexing.position) -> ([MLast.StDir (loc, n, dp)], true : 'use_file))]]; Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e), None, [None, None, @@ -2746,20 +3083,22 @@ Grammar.extend (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (sti : 'str_item) (loc : int * int) -> (sti : 'phrase)); + (fun _ (sti : 'str_item) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ (dp : 'expr option) (n : string) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (x : string) (loc : Lexing.position * Lexing.position) -> (let x = try let i = String.index x ':' in @@ -2772,14 +3111,16 @@ Grammar.extend 'expr)); [Gramext.Stoken ("LOCATE", "")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) (loc : Lexing.position * Lexing.position) -> (let x = try let i = String.index x ':' in - int_of_string (String.sub x 0 i), + {(Lexing.dummy_pos) with + Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, String.sub x (i + 1) (String.length x - i - 1) with - Not_found | Failure _ -> 0, x + Not_found | Failure _ -> + {(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x in Pcaml.handle_expr_locate loc x : 'expr))]]; @@ -2788,7 +3129,7 @@ Grammar.extend [None, None, [[Gramext.Stoken ("QUOTATION", "")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) (loc : Lexing.position * Lexing.position) -> (let x = try let i = String.index x ':' in @@ -2801,14 +3142,16 @@ Grammar.extend 'patt)); [Gramext.Stoken ("LOCATE", "")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) (loc : Lexing.position * Lexing.position) -> (let x = try let i = String.index x ':' in - int_of_string (String.sub x 0 i), + {(Lexing.dummy_pos) with + Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, String.sub x (i + 1) (String.length x - i - 1) with - Not_found | Failure _ -> 0, x + Not_found | Failure _ -> + {(Lexing.dummy_pos) with Lexing.pos_cnum = 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 index ad743e87..80d49d6e 100644 --- a/camlp4/ocaml_src/meta/pa_rp.ml +++ b/camlp4/ocaml_src/meta/pa_rp.ml @@ -487,7 +487,7 @@ Grammar.extend (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))], Gramext.action (fun (pc : 'parser_case) (po : 'ipatt option) _ _ (e : 'expr) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (cparser_match loc e po [pc] : 'expr)); [Gramext.Stoken ("", "match"); Gramext.Sself; Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser"); @@ -502,7 +502,7 @@ Grammar.extend Gramext.Stoken ("", "]")], Gramext.action (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ _ - (e : 'expr) _ (loc : int * int) -> + (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (cparser_match loc e po pcl : 'expr)); [Gramext.Stoken ("", "parser"); Gramext.Sopt @@ -511,7 +511,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))], Gramext.action - (fun (pc : 'parser_case) (po : 'ipatt option) _ (loc : int * int) -> + (fun (pc : 'parser_case) (po : 'ipatt option) _ + (loc : Lexing.position * Lexing.position) -> (cparser loc po [pc] : 'expr)); [Gramext.Stoken ("", "parser"); Gramext.Sopt @@ -525,7 +526,7 @@ Grammar.extend Gramext.Stoken ("", "]")], Gramext.action (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (cparser loc po pcl : 'expr))]]; Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e), None, [None, None, @@ -540,11 +541,14 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action (fun (e : 'expr) _ (po : 'ipatt option) _ (sp : 'stream_patt) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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.action + (fun (loc : Lexing.position * Lexing.position) -> + ([] : 'stream_patt)); [Gramext.Snterm (Grammar.Entry.obj (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e)); @@ -557,13 +561,14 @@ Grammar.extend Gramext.Stoken ("", ";"))], Gramext.action (fun (sp : 'stream_patt_comp_err list) _ (spc : 'stream_patt_comp) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> ((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) -> + (fun (spc : 'stream_patt_comp) + (loc : Lexing.position * Lexing.position) -> ([spc, None] : 'stream_patt))]]; Grammar.Entry.obj (stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e), @@ -578,23 +583,25 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'e__1))])], + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (e : 'e__1))])], Gramext.action (fun (eo : 'e__1 option) (spc : 'stream_patt_comp) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (p : 'patt) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'expr) _ (p : 'patt) + (loc : Lexing.position * Lexing.position) -> (SpNtr (loc, p, e) : 'stream_patt_comp)); [Gramext.Stoken ("", "`"); Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); @@ -604,15 +611,17 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'e__2))])], + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (e : 'e__2))])], Gramext.action - (fun (eo : 'e__2 option) (p : 'patt) _ (loc : int * int) -> + (fun (eo : 'e__2 option) (p : 'patt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : string) (loc : Lexing.position * Lexing.position) -> (MLast.PaLid (loc, i) : 'ipatt))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -625,17 +634,18 @@ Grammar.extend Gramext.Stoken ("", ";")); Gramext.Stoken ("", ":]")], Gramext.action - (fun _ (se : 'stream_expr_comp list) _ (loc : int * int) -> + (fun _ (se : 'stream_expr_comp list) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'expr) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (SeTrm (loc, e) : 'stream_expr_comp))]]]);; diff --git a/camlp4/ocaml_src/meta/q_MLast.ml b/camlp4/ocaml_src/meta/q_MLast.ml index 70540af6..dac10349 100644 --- a/camlp4/ocaml_src/meta/q_MLast.ml +++ b/camlp4/ocaml_src/meta/q_MLast.ml @@ -30,7 +30,12 @@ module Qast = | Loc | Antiquot of MLast.loc * string ;; - let loc = 0, 0;; + let loc = + let nowhere = + {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0} + in + nowhere, nowhere + ;; let rec to_expr = function Node (n, al) -> @@ -66,7 +71,9 @@ module Qast = 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)) + raise + (Stdpp.Exc_located + (Reloc.adjust_loc (fst loc) (bp, ep), exc)) in MLast.ExAnt (loc, e) and to_expr_label (l, a) = @@ -106,7 +113,9 @@ module Qast = 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)) + raise + (Stdpp.Exc_located + (Reloc.adjust_loc (fst loc) (bp, ep), exc)) in MLast.PaAnt (loc, p) and to_patt_label (l, a) = @@ -121,7 +130,7 @@ let antiquot k (bp, ep) x = if k = "" then String.length "$" else String.length "$" + String.length k + String.length ":" in - Qast.Antiquot ((shift + bp, shift + ep), x) + Qast.Antiquot ((Reloc.shift_pos shift bp, Reloc.shift_pos (-1) ep), x) ;; let sig_item = Grammar.Entry.create gram "signature item";; @@ -149,6 +158,9 @@ 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_INT32 = Grammar.Entry.create gram "a_INT32";; +let a_INT64 = Grammar.Entry.create gram "a_INT64";; +let a_NATIVEINT = Grammar.Entry.create gram "a__NATIVEINT";; 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";; @@ -295,7 +307,7 @@ let warn_variant _ = if !not_yet_warned_variant then begin not_yet_warned_variant := false; - !(Pcaml.warning) (0, 1) + !(Pcaml.warning) (Lexing.dummy_pos, Reloc.shift_pos 1 Lexing.dummy_pos) (Printf.sprintf "use of syntax of variants types deprecated since version 3.05") end @@ -306,7 +318,7 @@ let warn_sequence _ = if !not_yet_warned_seq then begin not_yet_warned_seq := false; - !(Pcaml.warning) (0, 1) + !(Pcaml.warning) (Lexing.dummy_pos, Reloc.shift_pos 1 Lexing.dummy_pos) (Printf.sprintf "use of syntax of sequences deprecated since version 3.01.1") end @@ -438,18 +450,20 @@ Grammar.extend (str_item : 'str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> + (fun _ (s : 'str_item) + (loc : Lexing.position * Lexing.position) -> (s : 'e__1))])], Gramext.action - (fun (a : 'e__1 list) (loc : int * int) -> + (fun (a : 'e__1 list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "end")], Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> + (fun _ (st : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("MeStr", [Qast.Loc; st]) : 'module_expr)); [Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); Gramext.Snterm @@ -460,22 +474,25 @@ Grammar.extend Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], Gramext.action (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (me2 : 'module_expr) (me1 : 'module_expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (me2 : 'module_expr) _ (me1 : 'module_expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (me : 'module_expr) _ + (loc : Lexing.position * Lexing.position) -> (me : 'module_expr)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); Gramext.Snterm @@ -483,18 +500,18 @@ Grammar.extend Gramext.Stoken ("", ")")], Gramext.action (fun _ (mt : 'module_type) _ (me : 'module_expr) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'expr) (loc : Lexing.position * Lexing.position) -> (Qast.Node ("StExp", [Qast.Loc; e]) : 'str_item)); [Gramext.Stoken ("", "value"); Gramext.srules @@ -502,15 +519,18 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "rec")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__3))])], Gramext.action - (fun (a : 'e__3 option) (loc : int * int) -> + (fun (a : 'e__3 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.srules [[Gramext.Slist1sep (Gramext.Snterm @@ -518,14 +538,17 @@ Grammar.extend (let_binding : 'let_binding Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> + (fun (a : 'let_binding list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (l : 'a_list) (r : 'a_opt) _ (loc : int * int) -> + (fun (l : 'a_list) (r : 'a_opt) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("StVal", [Qast.Loc; o2b r; l]) : 'str_item)); [Gramext.Stoken ("", "type"); Gramext.srules @@ -535,20 +558,22 @@ Grammar.extend (type_declaration : 'type_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'type_declaration list) (loc : int * int) -> + (fun (a : 'type_declaration list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (tdl : 'a_list) _ (loc : int * int) -> + (fun (tdl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'mod_ident) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("StOpn", [Qast.Loc; i]) : 'str_item)); [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); Gramext.Snterm @@ -557,7 +582,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], Gramext.action - (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ (loc : int * int) -> + (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("StMty", [Qast.Loc; i; mt]) : 'str_item)); [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); Gramext.srules @@ -568,14 +594,17 @@ Grammar.extend 'module_rec_binding Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'module_rec_binding list) (loc : int * int) -> + (fun (a : 'module_rec_binding list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (nmtmes : 'a_list) _ _ (loc : int * int) -> + (fun (nmtmes : 'a_list) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("StRecMod", [Qast.Loc; nmtmes]) : 'str_item)); [Gramext.Stoken ("", "module"); Gramext.Snterm @@ -584,13 +613,15 @@ Grammar.extend (Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e))], Gramext.action - (fun (mb : 'module_binding) (i : 'a_UIDENT) _ (loc : int * int) -> + (fun (mb : 'module_binding) (i : 'a_UIDENT) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (me : 'module_expr) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("StInc", [Qast.Loc; me]) : 'str_item)); [Gramext.Stoken ("", "external"); Gramext.Snterm @@ -603,15 +634,17 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))], Gramext.action - (fun (a : 'a_STRING list) (loc : int * int) -> + (fun (a : 'a_STRING list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action (fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("StExt", [Qast.Loc; i; t; pd]) : 'str_item)); [Gramext.Stoken ("", "exception"); Gramext.Snterm @@ -622,13 +655,11 @@ Grammar.extend (Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))], Gramext.action (fun (b : 'rebind_exn) (ctl : 'constructor_declaration) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (let (_, c, tl) = match ctl with Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 - | _ -> - match () with - _ -> raise (Match_failure ("q_MLast.ml", 302, 19)) + | _ -> match () with _ -> raise (Match_failure ("", 308, 19)) in Qast.Node ("StExc", [Qast.Loc; c; tl; b]) : 'str_item)); @@ -641,28 +672,33 @@ Grammar.extend (str_item : 'str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> + (fun _ (s : 'str_item) + (loc : Lexing.position * Lexing.position) -> (s : 'e__2))])], Gramext.action - (fun (a : 'e__2 list) (loc : int * int) -> + (fun (a : 'e__2 list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "end")], Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> + (fun _ (st : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (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.action + (fun (loc : Lexing.position * Lexing.position) -> + (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))]]; + (fun (sl : 'mod_ident) _ (loc : Lexing.position * Lexing.position) -> + (sl : 'rebind_exn))]]; Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e), None, [None, Some Gramext.RightA, @@ -670,7 +706,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], Gramext.action - (fun (me : 'module_expr) _ (loc : int * int) -> + (fun (me : 'module_expr) _ + (loc : Lexing.position * Lexing.position) -> (me : 'module_binding)); [Gramext.Stoken ("", ":"); Gramext.Snterm @@ -679,7 +716,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (loc : int * int) -> + (fun (me : 'module_expr) _ (mt : 'module_type) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_binding)); [Gramext.Stoken ("", "("); Gramext.Snterm @@ -690,7 +728,7 @@ Grammar.extend Gramext.Stoken ("", ")"); Gramext.Sself], Gramext.action (fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : 'a_UIDENT) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("MeFun", [Qast.Loc; m; mt; mb]) : 'module_binding))]]; Grammar.Entry.obj (module_rec_binding : 'module_rec_binding Grammar.Entry.e), @@ -706,7 +744,7 @@ Grammar.extend (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) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [m; me; mt] : 'module_rec_binding))]]; Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None, [None, None, @@ -717,7 +755,7 @@ Grammar.extend Gramext.Stoken ("", "->"); Gramext.Sself], Gramext.action (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_type))]; None, None, [[Gramext.Sself; Gramext.Stoken ("", "with"); @@ -728,14 +766,17 @@ Grammar.extend (with_constr : 'with_constr Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'with_constr list) (loc : int * int) -> + (fun (a : 'with_constr list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (wcl : 'a_list) _ (mt : 'module_type) (loc : int * int) -> + (fun (wcl : 'a_list) _ (mt : 'module_type) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("MtWit", [Qast.Loc; mt; wcl]) : 'module_type))]; None, None, [[Gramext.Stoken ("", "sig"); @@ -747,48 +788,53 @@ Grammar.extend (sig_item : 'sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> + (fun _ (s : 'sig_item) + (loc : Lexing.position * Lexing.position) -> (s : 'e__4))])], Gramext.action - (fun (a : 'e__4 list) (loc : int * int) -> + (fun (a : 'e__4 list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "end")], Gramext.action - (fun _ (sg : 'a_list) _ (loc : int * int) -> + (fun _ (sg : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (m2 : 'module_type) (m1 : 'module_type) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (m2 : 'module_type) _ (m1 : 'module_type) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (mt : 'module_type) _ + (loc : Lexing.position * Lexing.position) -> (mt : 'module_type)); [Gramext.Stoken ("", "'"); Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) -> (Qast.Node ("MtUid", [Qast.Loc; i]) : 'module_type))]]; Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, [Some "top", None, @@ -798,7 +844,8 @@ Grammar.extend Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ (loc : int * int) -> + (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("SgVal", [Qast.Loc; i; t]) : 'sig_item)); [Gramext.Stoken ("", "type"); Gramext.srules @@ -808,20 +855,22 @@ Grammar.extend (type_declaration : 'type_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'type_declaration list) (loc : int * int) -> + (fun (a : 'type_declaration list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (tdl : 'a_list) _ (loc : int * int) -> + (fun (tdl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'mod_ident) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("SgOpn", [Qast.Loc; i]) : 'sig_item)); [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); Gramext.srules @@ -832,14 +881,16 @@ Grammar.extend 'module_rec_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'module_rec_declaration list) (loc : int * int) -> + (fun (a : 'module_rec_declaration list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (mds : 'a_list) _ _ (loc : int * int) -> + (fun (mds : 'a_list) _ _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("SgRecMod", [Qast.Loc; mds]) : 'sig_item)); [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); Gramext.Snterm @@ -848,7 +899,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], Gramext.action - (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ (loc : int * int) -> + (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("SgMty", [Qast.Loc; i; mt]) : 'sig_item)); [Gramext.Stoken ("", "module"); Gramext.Snterm @@ -857,13 +909,15 @@ Grammar.extend (Grammar.Entry.obj (module_declaration : 'module_declaration Grammar.Entry.e))], Gramext.action - (fun (mt : 'module_declaration) (i : 'a_UIDENT) _ (loc : int * int) -> + (fun (mt : 'module_declaration) (i : 'a_UIDENT) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (mt : 'module_type) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("SgInc", [Qast.Loc; mt]) : 'sig_item)); [Gramext.Stoken ("", "external"); Gramext.Snterm @@ -876,15 +930,17 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))], Gramext.action - (fun (a : 'a_STRING list) (loc : int * int) -> + (fun (a : 'a_STRING list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action (fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("SgExt", [Qast.Loc; i; t; pd]) : 'sig_item)); [Gramext.Stoken ("", "exception"); Gramext.Snterm @@ -892,13 +948,12 @@ Grammar.extend (constructor_declaration : 'constructor_declaration Grammar.Entry.e))], Gramext.action - (fun (ctl : 'constructor_declaration) _ (loc : int * int) -> + (fun (ctl : 'constructor_declaration) _ + (loc : Lexing.position * Lexing.position) -> (let (_, c, tl) = match ctl with Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 - | _ -> - match () with - _ -> raise (Match_failure ("q_MLast.ml", 360, 19)) + | _ -> match () with _ -> raise (Match_failure ("", 366, 19)) in Qast.Node ("SgExc", [Qast.Loc; c; tl]) : 'sig_item)); @@ -911,18 +966,20 @@ Grammar.extend (sig_item : 'sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> + (fun _ (s : 'sig_item) + (loc : Lexing.position * Lexing.position) -> (s : 'e__5))])], Gramext.action - (fun (a : 'e__5 list) (loc : int * int) -> + (fun (a : 'e__5 list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "end")], Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> + (fun _ (st : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("SgDcl", [Qast.Loc; st]) : 'sig_item))]]; Grammar.Entry.obj (module_declaration : 'module_declaration Grammar.Entry.e), @@ -937,13 +994,14 @@ Grammar.extend Gramext.Stoken ("", ")"); Gramext.Sself], Gramext.action (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : 'a_UIDENT) - _ (loc : int * int) -> + _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (mt : 'module_type) _ + (loc : Lexing.position * Lexing.position) -> (mt : 'module_declaration))]]; Grammar.Entry.obj (module_rec_declaration : 'module_rec_declaration Grammar.Entry.e), @@ -955,7 +1013,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], Gramext.action - (fun (mt : 'module_type) _ (m : 'a_UIDENT) (loc : int * int) -> + (fun (mt : 'module_type) _ (m : 'a_UIDENT) + (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [m; mt] : 'module_rec_declaration))]]; Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None, [None, None, @@ -966,7 +1025,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], Gramext.action - (fun (me : 'module_expr) _ (i : 'mod_ident) _ (loc : int * int) -> + (fun (me : 'module_expr) _ (i : 'mod_ident) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("WcMod", [Qast.Loc; i; me]) : 'with_constr)); [Gramext.Stoken ("", "type"); Gramext.Snterm @@ -977,17 +1037,19 @@ Grammar.extend (Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e)))], Gramext.action - (fun (a : 'type_parameter list) (loc : int * int) -> + (fun (a : 'type_parameter list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (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) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("WcTyp", [Qast.Loc; i; tpl; t]) : 'with_constr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None, [Some "top", Some Gramext.RightA, @@ -997,7 +1059,8 @@ Grammar.extend (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); Gramext.Stoken ("", "}")], Gramext.action - (fun _ (seq : 'sequence) _ _ (e : 'expr) _ (loc : int * int) -> + (fun _ (seq : 'sequence) _ _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr)); [Gramext.Stoken ("", "for"); Gramext.Snterm @@ -1012,25 +1075,29 @@ Grammar.extend Gramext.Stoken ("", "}")], Gramext.action (fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : 'a_LIDENT) _ (loc : int * int) -> + (e1 : 'expr) _ (i : 'a_LIDENT) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (seq : 'sequence) _ _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExTry", [Qast.Loc; e; @@ -1045,22 +1112,26 @@ Grammar.extend (match_case : 'match_case Grammar.Entry.e)), Gramext.Stoken ("", "|"))], Gramext.action - (fun (a : 'match_case list) (loc : int * int) -> + (fun (a : 'match_case list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "]")], Gramext.action - (fun _ (l : 'a_list) _ _ (e : 'expr) _ (loc : int * int) -> + (fun _ (l : 'a_list) _ _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExMat", [Qast.Loc; e; @@ -1075,22 +1146,26 @@ Grammar.extend (match_case : 'match_case Grammar.Entry.e)), Gramext.Stoken ("", "|"))], Gramext.action - (fun (a : 'match_case list) (loc : int * int) -> + (fun (a : 'match_case list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "]")], Gramext.action - (fun _ (l : 'a_list) _ _ (e : 'expr) _ (loc : int * int) -> + (fun _ (l : 'a_list) _ _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'fun_def) (p : 'ipatt) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExFun", [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : @@ -1103,15 +1178,17 @@ Grammar.extend (match_case : 'match_case Grammar.Entry.e)), Gramext.Stoken ("", "|"))], Gramext.action - (fun (a : 'match_case list) (loc : int * int) -> + (fun (a : 'match_case list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "]")], Gramext.action - (fun _ (l : 'a_list) _ _ (loc : int * int) -> + (fun _ (l : 'a_list) _ _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExFun", [Qast.Loc; l]) : 'expr)); [Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module"); Gramext.Snterm @@ -1122,7 +1199,7 @@ Grammar.extend Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action (fun (e : 'expr) _ (mb : 'module_binding) (m : 'a_UIDENT) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExLmd", [Qast.Loc; m; mb; e]) : 'expr)); [Gramext.Stoken ("", "let"); Gramext.srules @@ -1130,15 +1207,18 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "rec")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__6))])], Gramext.action - (fun (a : 'e__6 option) (loc : int * int) -> + (fun (a : 'e__6 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.srules [[Gramext.Slist1sep (Gramext.Snterm @@ -1146,15 +1226,18 @@ Grammar.extend (let_binding : 'let_binding Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> + (fun (a : 'let_binding list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action - (fun (x : 'expr) _ (l : 'a_list) (r : 'a_opt) _ (loc : int * int) -> + (fun (x : 'expr) _ (l : 'a_list) (r : 'a_opt) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExLet", [Qast.Loc; o2b r; l; x]) : 'expr))]; Some "where", None, [[Gramext.Sself; Gramext.Stoken ("", "where"); @@ -1163,32 +1246,37 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "rec")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__7))])], Gramext.action - (fun (a : 'e__7 option) (loc : int * int) -> + (fun (a : 'e__7 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1201,7 +1289,8 @@ Grammar.extend Some "&&", Some Gramext.RightA, [[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1214,7 +1303,8 @@ Grammar.extend Some "<", Some Gramext.LeftA, [[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1226,7 +1316,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1238,7 +1329,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1250,7 +1342,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1262,7 +1355,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1274,7 +1368,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1286,7 +1381,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1298,7 +1394,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1311,7 +1408,8 @@ Grammar.extend Some "^", Some Gramext.RightA, [[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1323,7 +1421,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1336,7 +1435,8 @@ Grammar.extend Some "+", Some Gramext.LeftA, [[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1348,7 +1448,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1360,7 +1461,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1372,7 +1474,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1385,7 +1488,8 @@ Grammar.extend Some "*", Some Gramext.LeftA, [[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1397,7 +1501,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1409,7 +1514,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1421,7 +1527,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1433,7 +1540,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1445,7 +1553,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1457,7 +1566,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1469,7 +1579,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1482,7 +1593,8 @@ Grammar.extend Some "**", Some Gramext.RightA, [[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1494,7 +1606,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1506,7 +1619,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1518,7 +1632,8 @@ Grammar.extend 'expr)); [Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself], Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; @@ -1531,44 +1646,48 @@ Grammar.extend Some "unary minus", Some Gramext.NonA, [[Gramext.Stoken ("", "-."); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (mkumin Qast.Loc (Qast.Str "-.") e : 'expr)); [Gramext.Stoken ("", "-"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExLaz", [Qast.Loc; e]) : 'expr)); [Gramext.Stoken ("", "assert"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (mkassert Qast.Loc e : 'expr)); [Gramext.Sself; Gramext.Sself], Gramext.action - (fun (e2 : 'expr) (e1 : 'expr) (loc : int * int) -> + (fun (e2 : 'expr) (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e2 : 'expr) _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (e2 : 'expr) _ _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (e2 : 'expr) _ _ (e1 : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExAre", [Qast.Loc; e1; e2]) : 'expr))]; Some "~-", Some Gramext.NonA, [[Gramext.Stoken ("", "~-."); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-."]); @@ -1576,7 +1695,7 @@ Grammar.extend 'expr)); [Gramext.Stoken ("", "~-"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExApp", [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-"]); @@ -1584,7 +1703,9 @@ Grammar.extend 'expr))]; Some "simple", None, [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (e : 'expr) _ (loc : int * int) -> (e : 'expr)); + Gramext.action + (fun _ (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (e : 'expr)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); Gramext.srules [[Gramext.Slist1sep @@ -1592,25 +1713,28 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), Gramext.Stoken ("", ","))], Gramext.action - (fun (a : 'expr list) (loc : int * int) -> + (fun (a : 'expr list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (el : 'a_list) _ (e : 'expr) _ (loc : int * int) -> + (fun _ (el : 'a_list) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (t : 'ctyp) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'expr)); [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], Gramext.action - (fun _ _ (loc : int * int) -> + (fun _ _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExUid", [Qast.Loc; Qast.Str "()"]) : 'expr)); [Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with"); @@ -1621,15 +1745,18 @@ Grammar.extend (label_expr : 'label_expr Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'label_expr list) (loc : int * int) -> + (fun (a : 'label_expr list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "}")], Gramext.action - (fun _ (lel : 'a_list) _ _ (e : 'expr) _ _ (loc : int * int) -> + (fun _ (lel : 'a_list) _ _ (e : 'expr) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option (Some e)]) : 'expr)); [Gramext.Stoken ("", "{"); @@ -1640,15 +1767,17 @@ Grammar.extend (label_expr : 'label_expr Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'label_expr list) (loc : int * int) -> + (fun (a : 'label_expr list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "}")], Gramext.action - (fun _ (lel : 'a_list) _ (loc : int * int) -> + (fun _ (lel : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option None]) : 'expr)); [Gramext.Stoken ("", "[|"); Gramext.srules @@ -1657,15 +1786,16 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'expr list) (loc : int * int) -> + (fun (a : 'expr list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "|]")], Gramext.action - (fun _ (el : 'a_list) _ (loc : int * int) -> + (fun _ (el : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExArr", [Qast.Loc; el]) : 'expr)); [Gramext.Stoken ("", "["); Gramext.srules @@ -1674,69 +1804,94 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'expr list) (loc : int * int) -> + (fun (a : 'expr list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ (last : 'cons_expr_opt) (el : 'a_list) _ + (loc : Lexing.position * Lexing.position) -> (mklistexp Qast.Loc last el : 'expr)); [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], Gramext.action - (fun _ _ (loc : int * int) -> + (fun _ _ (loc : Lexing.position * Lexing.position) -> (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.action + (fun (i : 'expr_ident) (loc : Lexing.position * Lexing.position) -> + (i : 'expr)); [Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))], Gramext.action - (fun (s : 'a_CHAR) (loc : int * int) -> + (fun (s : 'a_CHAR) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'a_STRING) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'a_FLOAT) (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExFlo", [Qast.Loc; s]) : 'expr)); + [Gramext.Snterm + (Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))], + Gramext.action + (fun (s : 'a_NATIVEINT) (loc : Lexing.position * Lexing.position) -> + (Qast.Node ("ExNativeInt", [Qast.Loc; s]) : 'expr)); + [Gramext.Snterm + (Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))], + Gramext.action + (fun (s : 'a_INT64) (loc : Lexing.position * Lexing.position) -> + (Qast.Node ("ExInt64", [Qast.Loc; s]) : 'expr)); + [Gramext.Snterm + (Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))], + Gramext.action + (fun (s : 'a_INT32) (loc : Lexing.position * Lexing.position) -> + (Qast.Node ("ExInt32", [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) -> + (fun (s : 'a_INT) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (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))]]; + [[], + Gramext.action + (fun (loc : Lexing.position * Lexing.position) -> (() : '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)); + (fun (e : 'expr) (loc : Lexing.position * Lexing.position) -> + (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)); + (fun _ (e : 'expr) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (el : 'sequence) _ (e : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Cons (e, el) : 'sequence)); [Gramext.Stoken ("", "let"); Gramext.srules @@ -1744,15 +1899,18 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "rec")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__8))])], Gramext.action - (fun (a : 'e__8 option) (loc : int * int) -> + (fun (a : 'e__8 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.srules [[Gramext.Slist1sep (Gramext.Snterm @@ -1760,21 +1918,27 @@ Grammar.extend (let_binding : 'let_binding Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> + (fun (a : 'let_binding list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.srules [[Gramext.Stoken ("", ";")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__9)); + Gramext.action + (fun (x : string) (loc : Lexing.position * Lexing.position) -> + (x : 'e__9)); [Gramext.Stoken ("", "in")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__9))]; + Gramext.action + (fun (x : string) (loc : Lexing.position * Lexing.position) -> + (x : 'e__9))]; Gramext.Sself], Gramext.action (fun (el : 'sequence) _ (l : 'a_list) (rf : 'a_opt) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.List [Qast.Node ("ExLet", [Qast.Loc; o2b rf; l; mksequence Qast.Loc el])] : @@ -1785,7 +1949,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) -> + (fun (e : 'fun_binding) (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [p; e] : 'let_binding))]]; Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None, [None, Some Gramext.RightA, @@ -1794,16 +1959,19 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> + (fun (e : 'expr) _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (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)); + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (e : 'fun_binding) (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExFun", [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : @@ -1819,27 +1987,29 @@ Grammar.extend 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) -> + (p : 'patt) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (p : 'patt) _ (loc : Lexing.position * Lexing.position) -> (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)); + (fun (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> (Qast.Option (Some e) : 'when_expr_opt))]]; Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None, [None, None, @@ -1849,7 +2019,8 @@ Grammar.extend 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) -> + (fun (e : 'fun_binding) (i : 'patt_label_ident) + (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [i; e] : 'label_expr))]]; Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None, [None, Some Gramext.RightA, @@ -1857,27 +2028,31 @@ Grammar.extend (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) -> + (fun (j : 'expr_ident) _ (i : 'a_UIDENT) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> (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.action + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (e : 'fun_def) (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExFun", [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : @@ -1886,27 +2061,31 @@ Grammar.extend [None, Some Gramext.LeftA, [[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself], Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> + (fun (p2 : 'patt) _ (p1 : 'patt) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (p2 : 'patt) _ (p1 : 'patt) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (p2 : 'patt) (p1 : 'patt) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (p2 : 'patt) _ (p1 : 'patt) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt))]; Some "simple", None, [[Gramext.Stoken ("", "_")], Gramext.action - (fun _ (loc : int * int) -> + (fun _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaAny", [Qast.Loc]) : 'patt)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); Gramext.srules @@ -1915,32 +2094,38 @@ Grammar.extend (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), Gramext.Stoken ("", ","))], Gramext.action - (fun (a : 'patt list) (loc : int * int) -> + (fun (a : 'patt list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (pl : 'a_list) _ (p : 'patt) _ (loc : int * int) -> + (fun _ (pl : 'a_list) _ (p : 'patt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (p2 : 'patt) _ (p : 'patt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (t : 'ctyp) _ (p : 'patt) _ + (loc : Lexing.position * Lexing.position) -> (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.action + (fun _ (p : 'patt) _ (loc : Lexing.position * Lexing.position) -> + (p : 'patt)); [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], Gramext.action - (fun _ _ (loc : int * int) -> + (fun _ _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'patt)); [Gramext.Stoken ("", "{"); Gramext.srules @@ -1950,15 +2135,17 @@ Grammar.extend (label_patt : 'label_patt Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'label_patt list) (loc : int * int) -> + (fun (a : 'label_patt list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "}")], Gramext.action - (fun _ (lpl : 'a_list) _ (loc : int * int) -> + (fun _ (lpl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'patt)); [Gramext.Stoken ("", "[|"); Gramext.srules @@ -1967,15 +2154,16 @@ Grammar.extend (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'patt list) (loc : int * int) -> + (fun (a : 'patt list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "|]")], Gramext.action - (fun _ (pl : 'a_list) _ (loc : int * int) -> + (fun _ (pl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaArr", [Qast.Loc; pl]) : 'patt)); [Gramext.Stoken ("", "["); Gramext.srules @@ -1984,70 +2172,106 @@ Grammar.extend (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'patt list) (loc : int * int) -> + (fun (a : 'patt list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ (last : 'cons_patt_opt) (pl : 'a_list) _ + (loc : Lexing.position * Lexing.position) -> (mklistpat Qast.Loc last pl : 'patt)); [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], Gramext.action - (fun _ _ (loc : int * int) -> + (fun _ _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'a_FLOAT) _ (loc : Lexing.position * Lexing.position) -> (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool false) s : 'patt)); + [Gramext.Stoken ("", "-"); + Gramext.Snterm + (Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))], + Gramext.action + (fun (s : 'a_NATIVEINT) _ (loc : Lexing.position * Lexing.position) -> + (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt)); + [Gramext.Stoken ("", "-"); + Gramext.Snterm + (Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))], + Gramext.action + (fun (s : 'a_INT64) _ (loc : Lexing.position * Lexing.position) -> + (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt)); + [Gramext.Stoken ("", "-"); + Gramext.Snterm + (Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))], + Gramext.action + (fun (s : 'a_INT32) _ (loc : Lexing.position * Lexing.position) -> + (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) 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) -> + (fun (s : 'a_INT) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'a_CHAR) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'a_STRING) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'a_FLOAT) (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaFlo", [Qast.Loc; s]) : 'patt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))], + Gramext.action + (fun (s : 'a_NATIVEINT) (loc : Lexing.position * Lexing.position) -> + (Qast.Node ("PaNativeInt", [Qast.Loc; s]) : 'patt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))], + Gramext.action + (fun (s : 'a_INT64) (loc : Lexing.position * Lexing.position) -> + (Qast.Node ("PaInt64", [Qast.Loc; s]) : 'patt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))], + Gramext.action + (fun (s : 'a_INT32) (loc : Lexing.position * Lexing.position) -> + (Qast.Node ("PaInt32", [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) -> + (fun (s : 'a_INT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'a_UIDENT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (p : 'patt) _ (loc : Lexing.position * Lexing.position) -> (Qast.Option (Some p) : 'cons_patt_opt))]]; Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None, [None, None, @@ -2057,7 +2281,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], Gramext.action - (fun (p : 'patt) _ (i : 'patt_label_ident) (loc : int * int) -> + (fun (p : 'patt) _ (i : 'patt_label_ident) + (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [i; p] : 'label_patt))]]; Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), None, @@ -2065,29 +2290,29 @@ Grammar.extend [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], Gramext.action (fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaLid", [Qast.Loc; s]) : 'ipatt)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); Gramext.srules @@ -2096,32 +2321,39 @@ Grammar.extend (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)), Gramext.Stoken ("", ","))], Gramext.action - (fun (a : 'ipatt list) (loc : int * int) -> + (fun (a : 'ipatt list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (pl : 'a_list) _ (p : 'ipatt) _ (loc : int * int) -> + (fun _ (pl : 'a_list) _ (p : 'ipatt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (t : 'ctyp) _ (p : 'ipatt) _ + (loc : Lexing.position * Lexing.position) -> (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.action + (fun _ (p : 'ipatt) _ (loc : Lexing.position * Lexing.position) -> + (p : 'ipatt)); [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], Gramext.action - (fun _ _ (loc : int * int) -> + (fun _ _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'ipatt)); [Gramext.Stoken ("", "{"); Gramext.srules @@ -2131,15 +2363,17 @@ Grammar.extend (label_ipatt : 'label_ipatt Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'label_ipatt list) (loc : int * int) -> + (fun (a : 'label_ipatt list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "}")], Gramext.action - (fun _ (lpl : 'a_list) _ (loc : int * int) -> + (fun _ (lpl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'ipatt))]]; Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None, [None, None, @@ -2149,7 +2383,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], Gramext.action - (fun (p : 'ipatt) _ (i : 'patt_label_ident) (loc : int * int) -> + (fun (p : 'ipatt) _ (i : 'patt_label_ident) + (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [i; p] : 'label_ipatt))]]; Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e), None, @@ -2162,12 +2397,14 @@ Grammar.extend (Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e)))], Gramext.action - (fun (a : 'type_parameter list) (loc : int * int) -> + (fun (a : 'type_parameter list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.srules @@ -2176,22 +2413,24 @@ Grammar.extend (Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e)))], Gramext.action - (fun (a : 'constrain list) (loc : int * int) -> + (fun (a : 'constrain list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action (fun (cl : 'a_list) (tk : 'ctyp) _ (tpl : 'a_list) (n : 'type_patt) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (n : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [Qast.Loc; n] : 'type_patt))]]; Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None, [None, None, @@ -2200,7 +2439,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [t1; t2] : 'constrain))]]; Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e), None, @@ -2208,31 +2448,33 @@ Grammar.extend [[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'"); Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], Gramext.action - (fun (i : 'ident) _ _ (loc : int * int) -> + (fun (i : 'ident) _ _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'ident) _ _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyAli", [Qast.Loc; t1; t2]) : 'ctyp))]; None, Some Gramext.LeftA, [[Gramext.Stoken ("", "!"); @@ -2241,56 +2483,66 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e)))], Gramext.action - (fun (a : 'typevar list) (loc : int * int) -> + (fun (a : 'typevar list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "."); Gramext.Sself], Gramext.action - (fun (t : 'ctyp) _ (pl : 'a_list) _ (loc : int * int) -> + (fun (t : 'ctyp) _ (pl : 'a_list) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyArr", [Qast.Loc; t1; t2]) : 'ctyp))]; Some "label", Some Gramext.NonA, [[Gramext.Snterm (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); Gramext.Sself], Gramext.action - (fun (t : 'ctyp) (i : 'a_OPTLABEL) (loc : int * int) -> + (fun (t : 'ctyp) (i : 'a_OPTLABEL) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); [Gramext.Snterm (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (t : 'ctyp) _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> + (fun (t : 'ctyp) _ (i : 'a_QUESTIONIDENT) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); [Gramext.Snterm (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); Gramext.Sself], Gramext.action - (fun (t : 'ctyp) (i : 'a_LABEL) (loc : int * int) -> + (fun (t : 'ctyp) (i : 'a_LABEL) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp)); [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (t : 'ctyp) _ (i : 'a_TILDEIDENT) (loc : int * int) -> + (fun (t : 'ctyp) _ (i : 'a_TILDEIDENT) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp))]; None, Some Gramext.LeftA, [[Gramext.Sself; Gramext.Sself], Gramext.action - (fun (t2 : 'ctyp) (t1 : 'ctyp) (loc : int * int) -> + (fun (t2 : 'ctyp) (t1 : 'ctyp) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyAcc", [Qast.Loc; t1; t2]) : 'ctyp))]; Some "simple", None, [[Gramext.Stoken ("", "{"); @@ -2301,15 +2553,17 @@ Grammar.extend (label_declaration : 'label_declaration Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'label_declaration list) (loc : int * int) -> + (fun (a : 'label_declaration list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "}")], Gramext.action - (fun _ (ldl : 'a_list) _ (loc : int * int) -> + (fun _ (ldl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyRec", [Qast.Loc; Qast.Bool false; ldl]) : 'ctyp)); [Gramext.Stoken ("", "["); Gramext.srules @@ -2320,15 +2574,17 @@ Grammar.extend 'constructor_declaration Grammar.Entry.e)), Gramext.Stoken ("", "|"))], Gramext.action - (fun (a : 'constructor_declaration list) (loc : int * int) -> + (fun (a : 'constructor_declaration list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "]")], Gramext.action - (fun _ (cdl : 'a_list) _ (loc : int * int) -> + (fun _ (cdl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TySum", [Qast.Loc; Qast.Bool false; cdl]) : 'ctyp)); [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "{"); Gramext.srules @@ -2338,15 +2594,18 @@ Grammar.extend (label_declaration : 'label_declaration Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'label_declaration list) (loc : int * int) -> + (fun (a : 'label_declaration list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "}")], Gramext.action - (fun _ (ldl : 'a_list) _ _ (loc : int * int) -> + (fun _ (ldl : 'a_list) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyRec", [Qast.Loc; Qast.Bool true; ldl]) : 'ctyp)); [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "["); Gramext.srules @@ -2357,18 +2616,23 @@ Grammar.extend 'constructor_declaration Grammar.Entry.e)), Gramext.Stoken ("", "|"))], Gramext.action - (fun (a : 'constructor_declaration list) (loc : int * int) -> + (fun (a : 'constructor_declaration list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "]")], Gramext.action - (fun _ (cdl : 'a_list) _ _ (loc : int * int) -> + (fun _ (cdl : 'a_list) _ _ + (loc : Lexing.position * Lexing.position) -> (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.action + (fun _ (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) -> + (t : 'ctyp)); [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.srules [[Gramext.Slist1sep @@ -2376,34 +2640,36 @@ Grammar.extend (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), Gramext.Stoken ("", "*"))], Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> + (fun (a : 'ctyp list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (tl : 'a_list) _ (t : 'ctyp) _ (loc : int * int) -> + (fun _ (tl : 'a_list) _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyLid", [Qast.Loc; i]) : 'ctyp)); [Gramext.Stoken ("", "_")], Gramext.action - (fun _ (loc : int * int) -> + (fun _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyQuo", [Qast.Loc; i]) : 'ctyp))]]; Grammar.Entry.obj (constructor_declaration : 'constructor_declaration Grammar.Entry.e), @@ -2412,7 +2678,7 @@ Grammar.extend [[Gramext.Snterm (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], Gramext.action - (fun (ci : 'a_UIDENT) (loc : int * int) -> + (fun (ci : 'a_UIDENT) (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [Qast.Loc; ci; Qast.List []] : 'constructor_declaration)); [Gramext.Snterm @@ -2424,14 +2690,16 @@ Grammar.extend (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> + (fun (a : 'ctyp list) (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (cal : 'a_list) _ (ci : 'a_UIDENT) (loc : int * int) -> + (fun (cal : 'a_list) _ (ci : 'a_UIDENT) + (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [Qast.Loc; ci; cal] : 'constructor_declaration))]]; Grammar.Entry.obj (label_declaration : 'label_declaration Grammar.Entry.e), @@ -2445,45 +2713,53 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "mutable")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__10))])], Gramext.action - (fun (a : 'e__10 option) (loc : int * int) -> + (fun (a : 'e__10 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (t : 'ctyp) (mf : 'a_opt) _ (i : 'a_LIDENT) + (loc : Lexing.position * Lexing.position) -> (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.action + (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) -> + (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))]]; + (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (j : 'mod_ident) _ (i : 'a_UIDENT) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) -> (Qast.List [i] : 'mod_ident))]]; Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, [None, None, @@ -2496,14 +2772,16 @@ Grammar.extend 'class_type_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'class_type_declaration list) (loc : int * int) -> + (fun (a : 'class_type_declaration list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (ctd : 'a_list) _ _ (loc : int * int) -> + (fun (ctd : 'a_list) _ _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("StClt", [Qast.Loc; ctd]) : 'str_item)); [Gramext.Stoken ("", "class"); Gramext.srules @@ -2513,14 +2791,16 @@ Grammar.extend (class_declaration : 'class_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'class_declaration list) (loc : int * int) -> + (fun (a : 'class_declaration list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (cd : 'a_list) _ (loc : int * int) -> + (fun (cd : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("StCls", [Qast.Loc; cd]) : 'str_item))]]; Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, [None, None, @@ -2533,14 +2813,16 @@ Grammar.extend 'class_type_declaration Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'class_type_declaration list) (loc : int * int) -> + (fun (a : 'class_type_declaration list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (ctd : 'a_list) _ _ (loc : int * int) -> + (fun (ctd : 'a_list) _ _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("SgClt", [Qast.Loc; ctd]) : 'sig_item)); [Gramext.Stoken ("", "class"); Gramext.srules @@ -2550,14 +2832,16 @@ Grammar.extend (class_description : 'class_description Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'class_description list) (loc : int * int) -> + (fun (a : 'class_description list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (cd : 'a_list) _ (loc : int * int) -> + (fun (cd : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("SgCls", [Qast.Loc; cd]) : 'sig_item))]]; Grammar.Entry.obj (class_declaration : 'class_declaration Grammar.Entry.e), @@ -2568,15 +2852,18 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "virtual")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__11))])], Gramext.action - (fun (a : 'e__11 option) (loc : int * int) -> + (fun (a : 'e__11 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); Gramext.Snterm @@ -2587,7 +2874,8 @@ Grammar.extend (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) -> + (i : 'a_LIDENT) (vf : 'a_opt) + (loc : Lexing.position * Lexing.position) -> (Qast.Record ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", i; "ciExp", cfb] : @@ -2599,7 +2887,8 @@ Grammar.extend [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); Gramext.Sself], Gramext.action - (fun (cfb : 'class_fun_binding) (p : 'ipatt) (loc : int * int) -> + (fun (cfb : 'class_fun_binding) (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CeFun", [Qast.Loc; p; cfb]) : 'class_fun_binding)); [Gramext.Stoken ("", ":"); Gramext.Snterm @@ -2608,13 +2897,14 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], Gramext.action - (fun (ce : 'class_expr) _ (ct : 'class_type) _ (loc : int * int) -> + (fun (ce : 'class_expr) _ (ct : 'class_type) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (ce : 'class_expr) _ (loc : Lexing.position * Lexing.position) -> (ce : 'class_fun_binding))]]; Grammar.Entry.obj (class_type_parameters : 'class_type_parameters Grammar.Entry.e), @@ -2628,19 +2918,21 @@ Grammar.extend (type_parameter : 'type_parameter Grammar.Entry.e)), Gramext.Stoken ("", ","))], Gramext.action - (fun (a : 'type_parameter list) (loc : int * int) -> + (fun (a : 'type_parameter list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "]")], Gramext.action - (fun _ (tpl : 'a_list) _ (loc : int * int) -> + (fun _ (tpl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [Qast.Loc; tpl] : 'class_type_parameters)); [], Gramext.action - (fun (loc : int * int) -> + (fun (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [Qast.Loc; Qast.List []] : 'class_type_parameters))]]; Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None, [None, None, @@ -2648,11 +2940,13 @@ Grammar.extend 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)); + (fun (ce : 'class_expr) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (ce : 'class_fun_def) (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_fun_def))]]; Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None, [Some "top", None, @@ -2662,15 +2956,18 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "rec")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__12))])], Gramext.action - (fun (a : 'e__12 option) (loc : int * int) -> + (fun (a : 'e__12 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.srules [[Gramext.Slist1sep (Gramext.Snterm @@ -2678,16 +2975,18 @@ Grammar.extend (let_binding : 'let_binding Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> + (fun (a : 'let_binding list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action (fun (ce : 'class_expr) _ (lb : 'a_list) (rf : 'a_opt) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CeLet", [Qast.Loc; o2b rf; lb; ce]) : 'class_expr)); [Gramext.Stoken ("", "fun"); Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); @@ -2695,25 +2994,30 @@ Grammar.extend (Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e))], Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) _ (loc : int * int) -> + (fun (ce : 'class_fun_def) (p : 'ipatt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (e : 'expr) (ce : 'class_expr) + (loc : Lexing.position * Lexing.position) -> (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)); + (fun _ (ce : 'class_expr) _ + (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_expr)); [Gramext.Stoken ("", "object"); Gramext.srules @@ -2722,24 +3026,28 @@ Grammar.extend (Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e)))], Gramext.action - (fun (a : 'class_self_patt option) (loc : int * int) -> + (fun (a : 'class_self_patt option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ (cf : 'class_structure) (cspo : 'a_opt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (ci : 'class_longident) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CeCon", [Qast.Loc; ci; Qast.List []]) : 'class_expr)); [Gramext.Snterm (Grammar.Entry.obj @@ -2751,15 +3059,17 @@ Grammar.extend (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), Gramext.Stoken ("", ","))], Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> + (fun (a : 'ctyp list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "]")], Gramext.action - (fun _ (ctcl : 'a_list) _ (ci : 'class_longident) (loc : int * int) -> + (fun _ (ctcl : 'a_list) _ (ci : 'class_longident) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CeCon", [Qast.Loc; ci; ctcl]) : 'class_expr))]]; Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e), None, @@ -2772,17 +3082,21 @@ Grammar.extend (class_str_item : 'class_str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (cf : 'class_str_item) (loc : int * int) -> + (fun _ (cf : 'class_str_item) + (loc : Lexing.position * Lexing.position) -> (cf : 'e__13))])], Gramext.action - (fun (a : 'e__13 list) (loc : int * int) -> + (fun (a : 'e__13 list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (cf : 'a_list) (loc : int * int) -> (cf : 'class_structure))]]; + (fun (cf : 'a_list) (loc : Lexing.position * Lexing.position) -> + (cf : 'class_structure))]]; Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e), None, [None, None, @@ -2792,27 +3106,30 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> + (fun _ (t : 'ctyp) _ (p : 'patt) _ + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun _ (p : 'patt) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (se : 'expr) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CrCtr", [Qast.Loc; t1; t2]) : 'class_str_item)); [Gramext.Stoken ("", "method"); Gramext.srules @@ -2820,32 +3137,37 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "private")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__17))])], Gramext.action - (fun (a : 'e__17 option) (loc : int * int) -> + (fun (a : 'e__17 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (a : 'polyt option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CrMth", [Qast.Loc; l; o2b pf; e; topt]) : 'class_str_item)); [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); @@ -2854,20 +3176,24 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "private")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__16))])], Gramext.action - (fun (a : 'e__16 option) (loc : int * int) -> + (fun (a : 'e__16 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CrVir", [Qast.Loc; l; o2b pf; t]) : 'class_str_item)); [Gramext.Stoken ("", "value"); Gramext.srules @@ -2875,22 +3201,25 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "mutable")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__15))])], Gramext.action - (fun (a : 'e__15 option) (loc : int * int) -> + (fun (a : 'e__15 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) : 'class_str_item)); [Gramext.Stoken ("", "inherit"); @@ -2902,14 +3231,17 @@ Grammar.extend (Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e)))], Gramext.action - (fun (a : 'as_lident option) (loc : int * int) -> + (fun (a : 'as_lident option) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]], Gramext.action - (fun (pb : 'a_opt) (ce : 'class_expr) _ (loc : int * int) -> + (fun (pb : 'a_opt) (ce : 'class_expr) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CrInh", [Qast.Loc; ce; pb]) : 'class_str_item)); [Gramext.Stoken ("", "declare"); Gramext.srules @@ -2920,18 +3252,21 @@ Grammar.extend (class_str_item : 'class_str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'class_str_item) (loc : int * int) -> + (fun _ (s : 'class_str_item) + (loc : Lexing.position * Lexing.position) -> (s : 'e__14))])], Gramext.action - (fun (a : 'e__14 list) (loc : int * int) -> + (fun (a : 'e__14 list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "end")], Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> + (fun _ (st : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CrDcl", [Qast.Loc; st]) : 'class_str_item))]]; Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None, [None, None, @@ -2939,12 +3274,15 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], Gramext.action - (fun (i : 'a_LIDENT) _ (loc : int * int) -> (i : 'as_lident))]]; + (fun (i : 'a_LIDENT) _ (loc : Lexing.position * Lexing.position) -> + (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))]]; + Gramext.action + (fun (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) -> + (t : 'polyt))]]; Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e), None, [None, None, @@ -2953,7 +3291,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> + (fun (e : 'expr) _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) : 'cvalue_binding)); [Gramext.Stoken ("", ":"); @@ -2963,7 +3302,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (loc : int * int) -> + (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) : 'cvalue_binding)); [Gramext.Stoken ("", ":"); @@ -2971,18 +3311,21 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> + (fun (e : 'expr) _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (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))]]; + (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> + (i : 'label))]]; Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("", "object"); @@ -2992,12 +3335,14 @@ Grammar.extend (Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e)))], Gramext.action - (fun (a : 'class_self_type option) (loc : int * int) -> + (fun (a : 'class_self_type option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.srules [[Gramext.Slist0 (Gramext.srules @@ -3006,24 +3351,29 @@ Grammar.extend (class_sig_item : 'class_sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> + (fun _ (csf : 'class_sig_item) + (loc : Lexing.position * Lexing.position) -> (csf : 'e__18))])], Gramext.action - (fun (a : 'e__18 list) (loc : int * int) -> + (fun (a : 'e__18 list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "end")], Gramext.action - (fun _ (csf : 'a_list) (cst : 'a_opt) _ (loc : int * int) -> + (fun _ (csf : 'a_list) (cst : 'a_opt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (id : 'clty_longident) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CtCon", [Qast.Loc; id; Qast.List []]) : 'class_type)); [Gramext.Snterm (Grammar.Entry.obj @@ -3035,21 +3385,24 @@ Grammar.extend (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), Gramext.Stoken ("", ","))], Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> + (fun (a : 'ctyp list) (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "]")], Gramext.action - (fun _ (tl : 'a_list) _ (id : 'clty_longident) (loc : int * int) -> + (fun _ (tl : 'a_list) _ (id : 'clty_longident) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (ct : 'class_type) _ _ (t : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CtFun", [Qast.Loc; t; ct]) : 'class_type))]]; Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e), None, @@ -3058,7 +3411,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'class_self_type))]]; + (fun _ (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) -> + (t : 'class_self_type))]]; Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), None, [None, None, @@ -3067,7 +3421,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CgCtr", [Qast.Loc; t1; t2]) : 'class_sig_item)); [Gramext.Stoken ("", "method"); Gramext.srules @@ -3075,20 +3430,24 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "private")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__22))])], Gramext.action - (fun (a : 'e__22 option) (loc : int * int) -> + (fun (a : 'e__22 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CgMth", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item)); [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); Gramext.srules @@ -3096,20 +3455,24 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "private")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__21))])], Gramext.action - (fun (a : 'e__21 option) (loc : int * int) -> + (fun (a : 'e__21 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CgVir", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item)); [Gramext.Stoken ("", "value"); Gramext.srules @@ -3117,26 +3480,30 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "mutable")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__20))])], Gramext.action - (fun (a : 'e__20 option) (loc : int * int) -> + (fun (a : 'e__20 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (cs : 'class_type) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CgInh", [Qast.Loc; cs]) : 'class_sig_item)); [Gramext.Stoken ("", "declare"); Gramext.srules @@ -3147,18 +3514,21 @@ Grammar.extend (class_sig_item : 'class_sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (s : 'class_sig_item) (loc : int * int) -> + (fun _ (s : 'class_sig_item) + (loc : Lexing.position * Lexing.position) -> (s : 'e__19))])], Gramext.action - (fun (a : 'e__19 list) (loc : int * int) -> + (fun (a : 'e__19 list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "end")], Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> + (fun _ (st : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("CgDcl", [Qast.Loc; st]) : 'class_sig_item))]]; Grammar.Entry.obj (class_description : 'class_description Grammar.Entry.e), @@ -3169,15 +3539,18 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "virtual")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__23))])], Gramext.action - (fun (a : 'e__23 option) (loc : int * int) -> + (fun (a : 'e__23 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); Gramext.Snterm @@ -3188,7 +3561,8 @@ Grammar.extend (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) -> + (n : 'a_LIDENT) (vf : 'a_opt) + (loc : Lexing.position * Lexing.position) -> (Qast.Record ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n; "ciExp", ct] : @@ -3202,15 +3576,18 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "virtual")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__24))])], Gramext.action - (fun (a : 'e__24 option) (loc : int * int) -> + (fun (a : 'e__24 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.Snterm (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); Gramext.Snterm @@ -3221,7 +3598,8 @@ Grammar.extend (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) -> + (n : 'a_LIDENT) (vf : 'a_opt) + (loc : Lexing.position * Lexing.position) -> (Qast.Record ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n; "ciExp", cs] : @@ -3234,7 +3612,8 @@ Grammar.extend (Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e))], Gramext.action - (fun (i : 'class_longident) _ (loc : int * int) -> + (fun (i : 'class_longident) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExNew", [Qast.Loc; i]) : 'expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "."), @@ -3242,7 +3621,8 @@ Grammar.extend [[Gramext.Sself; Gramext.Stoken ("", "#"); Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))], Gramext.action - (fun (lab : 'label) _ (e : 'expr) (loc : int * int) -> + (fun (lab : 'label) _ (e : 'expr) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExSnd", [Qast.Loc; e; lab]) : 'expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -3255,21 +3635,24 @@ Grammar.extend (field_expr : 'field_expr Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'field_expr list) (loc : int * int) -> + (fun (a : 'field_expr list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", ">}")], Gramext.action - (fun _ (fel : 'a_list) _ (loc : int * int) -> + (fun _ (fel : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun _ (t : 'ctyp) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (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)); @@ -3277,7 +3660,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> + (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) : 'expr))]]; Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None, @@ -3286,7 +3670,8 @@ Grammar.extend Gramext.Stoken ("", "="); Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) _ (l : 'label) (loc : int * int) -> + (fun (e : 'expr) _ (l : 'label) + (loc : Lexing.position * Lexing.position) -> (Qast.Tuple [l; e] : 'field_expr))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -3298,36 +3683,43 @@ Grammar.extend (Grammar.Entry.obj (field : 'field Grammar.Entry.e)), Gramext.Stoken ("", ";"))], Gramext.action - (fun (a : 'field list) (loc : int * int) -> + (fun (a : 'field list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.srules [[Gramext.Sopt (Gramext.srules [[Gramext.Stoken ("", "..")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__25))])], Gramext.action - (fun (a : 'e__25 option) (loc : int * int) -> + (fun (a : 'e__25 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.Stoken ("", ">")], Gramext.action - (fun _ (v : 'a_opt) (ml : 'a_list) _ (loc : int * int) -> + (fun _ (v : 'a_opt) (ml : 'a_list) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (id : 'class_longident) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyCls", [Qast.Loc; id]) : 'ctyp))]]; Grammar.Entry.obj (field : 'field Grammar.Entry.e), None, [None, None, @@ -3336,27 +3728,30 @@ Grammar.extend Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (lab : 'a_LIDENT) (loc : int * int) -> + (fun (t : 'ctyp) _ (lab : 'a_LIDENT) + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (l : 'clty_longident) _ (m : 'a_UIDENT) + (loc : Lexing.position * Lexing.position) -> (Qast.Cons (m, l) : 'clty_longident))]]; Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e), None, @@ -3364,18 +3759,58 @@ Grammar.extend [[Gramext.Snterm (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> + (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (l : 'class_longident) _ (m : 'a_UIDENT) + (loc : Lexing.position * Lexing.position) -> (Qast.Cons (m, l) : 'class_longident))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, - [[Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); + [[Gramext.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 : Lexing.position * Lexing.position) -> + (Qast.List a : 'a_list)); + [Gramext.Snterm + (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; + Gramext.Stoken ("", "]")], + Gramext.action + (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ + (loc : Lexing.position * Lexing.position) -> + (Qast.Node + ("TyVrn", + [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) : + 'ctyp)); + [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 : Lexing.position * Lexing.position) -> + (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)); @@ -3385,16 +3820,18 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))], Gramext.action - (fun (a : 'name_tag list) (loc : int * int) -> + (fun (a : 'name_tag list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "]")], Gramext.action (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) : @@ -3405,7 +3842,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyVrn", [Qast.Loc; rfl; @@ -3417,7 +3855,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) : @@ -3428,7 +3867,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) : 'ctyp))]]; Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e), @@ -3440,19 +3880,22 @@ Grammar.extend (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)), Gramext.Stoken ("", "|"))], Gramext.action - (fun (a : 'row_field list) (loc : int * int) -> + (fun (a : 'row_field list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (rfl : 'a_list) (loc : int * int) -> (rfl : 'row_field_list))]]; + (fun (rfl : 'a_list) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (t : 'ctyp) (loc : Lexing.position * Lexing.position) -> (Qast.Node ("RfInh", [t]) : 'row_field)); [Gramext.Stoken ("", "`"); Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e)); @@ -3462,34 +3905,39 @@ Grammar.extend (Gramext.srules [[Gramext.Stoken ("", "&")], Gramext.action - (fun (x : string) (loc : int * int) -> + (fun (x : string) + (loc : Lexing.position * Lexing.position) -> (Qast.Str x : 'e__26))])], Gramext.action - (fun (a : 'e__26 option) (loc : int * int) -> + (fun (a : 'e__26 option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (a : 'ctyp list) (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (l : 'a_list) (ao : 'a_opt) _ (i : 'ident) _ (loc : int * int) -> + (fun (l : 'a_list) (ao : 'a_opt) _ (i : 'ident) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("RfTag", [i; Qast.Bool true; Qast.List []]) : 'row_field))]]; Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None, @@ -3497,7 +3945,8 @@ Grammar.extend [[Gramext.Stoken ("", "`"); Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> (i : 'name_tag))]]; + (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) -> + (i : 'name_tag))]]; Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, @@ -3509,15 +3958,18 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> + (fun (a : 'eq_expr option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (loc : int * int) -> + (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaOlb", [Qast.Loc; Qast.Str ""; @@ -3527,7 +3979,8 @@ Grammar.extend (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], Gramext.action - (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> + (fun (i : 'a_QUESTIONIDENT) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'patt)); [Gramext.Snterm (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); @@ -3539,16 +3992,18 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> + (fun (a : 'eq_expr option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.Stoken ("", ")")], Gramext.action (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ (i : 'a_OPTLABEL) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : @@ -3564,16 +4019,18 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> + (fun (a : 'eq_expr option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.Stoken ("", ")")], Gramext.action (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (i : 'a_QUESTIONIDENT) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : @@ -3581,42 +4038,47 @@ Grammar.extend [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], Gramext.action - (fun (i : 'a_TILDEIDENT) (loc : int * int) -> + (fun (i : 'a_TILDEIDENT) (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'patt)); [Gramext.Snterm (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); Gramext.Sself], Gramext.action - (fun (p : 'patt) (i : 'a_LABEL) (loc : int * int) -> + (fun (p : 'patt) (i : 'a_LABEL) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : 'patt)); [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (p : 'patt) _ (i : 'a_TILDEIDENT) (loc : int * int) -> + (fun (p : 'patt) _ (i : 'a_TILDEIDENT) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (sl : 'mod_ident) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (s : 'ident) _ (loc : Lexing.position * Lexing.position) -> (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.action + (fun (p : 'patt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (t : 'ctyp) _ (p : 'patt) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt_tcon))]]; Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, [None, None, @@ -3628,15 +4090,18 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> + (fun (a : 'eq_expr option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.Stoken ("", ")")], Gramext.action - (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (loc : int * int) -> + (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaOlb", [Qast.Loc; Qast.Str ""; @@ -3646,7 +4111,8 @@ Grammar.extend (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], Gramext.action - (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> + (fun (i : 'a_QUESTIONIDENT) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); [Gramext.Snterm (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); @@ -3658,16 +4124,18 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> + (fun (a : 'eq_expr option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.Stoken ("", ")")], Gramext.action (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ (i : 'a_OPTLABEL) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : @@ -3683,16 +4151,18 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> + (fun (a : 'eq_expr option) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; Gramext.Stoken ("", ")")], Gramext.action (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (i : 'a_QUESTIONIDENT) - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : @@ -3700,39 +4170,44 @@ Grammar.extend [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], Gramext.action - (fun (i : 'a_TILDEIDENT) (loc : int * int) -> + (fun (i : 'a_TILDEIDENT) (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); [Gramext.Snterm (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); Gramext.Sself], Gramext.action - (fun (p : 'ipatt) (i : 'a_LABEL) (loc : int * int) -> + (fun (p : 'ipatt) (i : 'a_LABEL) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : 'ipatt)); [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (p : 'ipatt) _ (i : 'a_TILDEIDENT) (loc : int * int) -> + (fun (p : 'ipatt) _ (i : 'a_TILDEIDENT) + (loc : Lexing.position * Lexing.position) -> (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)); + (fun (p : 'ipatt) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (t : 'ctyp) _ (p : 'ipatt) + (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) -> + (e : 'eq_expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.After "apply"), [Some "label", Some Gramext.NonA, @@ -3740,13 +4215,15 @@ Grammar.extend (Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], Gramext.action - (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> + (fun (i : 'a_QUESTIONIDENT) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option None]) : 'expr)); [Gramext.Snterm (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); Gramext.Sself], Gramext.action - (fun (e : 'expr) (i : 'a_OPTLABEL) (loc : int * int) -> + (fun (e : 'expr) (i : 'a_OPTLABEL) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) : 'expr)); [Gramext.Snterm @@ -3754,26 +4231,29 @@ Grammar.extend (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> + (fun (e : 'expr) _ (i : 'a_QUESTIONIDENT) + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (i : 'a_TILDEIDENT) (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option None]) : 'expr)); [Gramext.Snterm (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); Gramext.Sself], Gramext.action - (fun (e : 'expr) (i : 'a_LABEL) (loc : int * int) -> + (fun (e : 'expr) (i : 'a_LABEL) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) : 'expr)); [Gramext.Snterm (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Sself], Gramext.action - (fun (e : 'expr) _ (i : 'a_TILDEIDENT) (loc : int * int) -> + (fun (e : 'expr) _ (i : 'a_TILDEIDENT) + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) : 'expr))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), @@ -3782,17 +4262,19 @@ Grammar.extend [[Gramext.Stoken ("", "`"); Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], Gramext.action - (fun (s : 'ident) _ (loc : int * int) -> + (fun (s : 'ident) _ (loc : Lexing.position * Lexing.position) -> (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)); + (fun _ (loc : Lexing.position * Lexing.position) -> + (Qast.Bool false : 'direction_flag)); [Gramext.Stoken ("", "to")], Gramext.action - (fun _ (loc : int * int) -> (Qast.Bool true : 'direction_flag))]]; + (fun _ (loc : Lexing.position * Lexing.position) -> + (Qast.Bool true : 'direction_flag))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), [None, None, @@ -3810,16 +4292,18 @@ Grammar.extend (Gramext.Snterm (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))], Gramext.action - (fun (a : 'name_tag list) (loc : int * int) -> + (fun (a : 'name_tag list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "|]")], Gramext.action (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _ _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) : @@ -3834,7 +4318,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "|]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyVrn", [Qast.Loc; rfl; @@ -3850,7 +4335,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "|]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) : @@ -3864,7 +4350,8 @@ Grammar.extend (row_field_list : 'row_field_list Grammar.Entry.e)); Gramext.Stoken ("", "|]")], Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> + (fun _ (rfl : 'row_field_list) _ _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) : 'ctyp))]]; Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e), @@ -3872,7 +4359,7 @@ Grammar.extend [None, None, [[], Gramext.action - (fun (loc : int * int) -> + (fun (loc : Lexing.position * Lexing.position) -> (warn_variant Qast.Loc : 'warning_variant))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "top"), @@ -3885,20 +4372,25 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__29))])], + (fun _ (e : 'expr) + (loc : Lexing.position * Lexing.position) -> + (e : 'e__29))])], Gramext.action - (fun (a : 'e__29 list) (loc : int * int) -> + (fun (a : 'e__29 list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun _ _ (seq : 'a_list) _ (e : 'expr) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr)); [Gramext.Stoken ("", "for"); Gramext.Snterm @@ -3915,21 +4407,26 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__28))])], + (fun _ (e : 'expr) + (loc : Lexing.position * Lexing.position) -> + (e : 'e__28))])], Gramext.action - (fun (a : 'e__28 list) (loc : int * int) -> + (fun (a : 'e__28 list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (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) -> + (e1 : 'expr) _ (i : 'a_LIDENT) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr)); [Gramext.Stoken ("", "do"); Gramext.srules @@ -3939,78 +4436,85 @@ Grammar.extend (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__27))])], + (fun _ (e : 'expr) + (loc : Lexing.position * Lexing.position) -> + (e : 'e__27))])], Gramext.action - (fun (a : 'e__27 list) (loc : int * int) -> + (fun (a : 'e__27 list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (e : 'expr) _ _ (seq : 'a_list) _ + (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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))]]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (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))]]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "to" loc a : 'direction_flag))]]; Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -4025,18 +4529,22 @@ Grammar.extend (class_str_item : 'class_str_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (cf : 'class_str_item) (loc : int * int) -> + (fun _ (cf : 'class_str_item) + (loc : Lexing.position * Lexing.position) -> (cf : 'e__30))])], Gramext.action - (fun (a : 'e__30 list) (loc : int * int) -> + (fun (a : 'e__30 list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "end")], Gramext.action - (fun _ (csl : 'a_list) _ (x : string) _ (loc : int * int) -> + (fun _ (csl : 'a_list) _ (x : string) _ + (loc : Lexing.position * Lexing.position) -> (let _ = warn_antiq loc "3.05" in Qast.Node ("CeStr", @@ -4049,7 +4557,8 @@ Grammar.extend (class_structure : 'class_structure Grammar.Entry.e)); Gramext.Stoken ("", "end")], Gramext.action - (fun _ (cf : 'class_structure) (x : string) _ (loc : int * int) -> + (fun _ (cf : 'class_structure) (x : string) _ + (loc : Lexing.position * Lexing.position) -> (let _ = warn_antiq loc "3.05" in Qast.Node ("CeStr", [Qast.Loc; antiquot "" loc x; cf]) : 'class_expr))]]; @@ -4065,18 +4574,22 @@ Grammar.extend (class_sig_item : 'class_sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> + (fun _ (csf : 'class_sig_item) + (loc : Lexing.position * Lexing.position) -> (csf : 'e__32))])], Gramext.action - (fun (a : 'e__32 list) (loc : int * int) -> + (fun (a : 'e__32 list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "end")], Gramext.action - (fun _ (csf : 'a_list) _ (x : string) _ (loc : int * int) -> + (fun _ (csf : 'a_list) _ (x : string) _ + (loc : Lexing.position * Lexing.position) -> (let _ = warn_antiq loc "3.05" in Qast.Node ("CtSig", @@ -4092,18 +4605,22 @@ Grammar.extend (class_sig_item : 'class_sig_item Grammar.Entry.e)); Gramext.Stoken ("", ";")], Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> + (fun _ (csf : 'class_sig_item) + (loc : Lexing.position * Lexing.position) -> (csf : 'e__31))])], Gramext.action - (fun (a : 'e__31 list) (loc : int * int) -> + (fun (a : 'e__31 list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "end")], Gramext.action - (fun _ (csf : 'a_list) (x : string) _ (loc : int * int) -> + (fun _ (csf : 'a_list) (x : string) _ + (loc : Lexing.position * Lexing.position) -> (let _ = warn_antiq loc "3.05" in Qast.Node ("CtSig", [Qast.Loc; antiquot "" loc x; csf]) : 'class_type))]]; @@ -4118,15 +4635,18 @@ Grammar.extend (let_binding : 'let_binding Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> + (fun (a : 'let_binding list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action - (fun (x : 'expr) _ (l : 'a_list) (r : string) _ (loc : int * int) -> + (fun (x : 'expr) _ (l : 'a_list) (r : string) _ + (loc : Lexing.position * Lexing.position) -> (let _ = warn_antiq loc "3.06+18" in Qast.Node ("ExLet", [Qast.Loc; antiquot "rec" loc r; l; x]) : 'expr))]]; @@ -4141,14 +4661,17 @@ Grammar.extend (let_binding : 'let_binding Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> + (fun (a : 'let_binding list) + (loc : Lexing.position * Lexing.position) -> (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))]], + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]], Gramext.action - (fun (l : 'a_list) (r : string) _ (loc : int * int) -> + (fun (l : 'a_list) (r : string) _ + (loc : Lexing.position * Lexing.position) -> (let _ = warn_antiq loc "3.06+18" in Qast.Node ("StVal", [Qast.Loc; antiquot "rec" loc r; l]) : 'str_item))]]; @@ -4163,16 +4686,18 @@ Grammar.extend (let_binding : 'let_binding Grammar.Entry.e)), Gramext.Stoken ("", "and"))], Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> + (fun (a : 'let_binding list) + (loc : Lexing.position * Lexing.position) -> (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))]; + (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) -> + (a : 'a_list))]; Gramext.Stoken ("", "in"); Gramext.Sself], Gramext.action (fun (ce : 'class_expr) _ (lb : 'a_list) (r : string) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (let _ = warn_antiq loc "3.06+18" in Qast.Node ("CeLet", [Qast.Loc; antiquot "rec" loc r; lb; ce]) : 'class_expr))]]; @@ -4186,7 +4711,7 @@ Grammar.extend (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], Gramext.action (fun (e : 'cvalue_binding) (lab : 'label) (mf : string) _ - (loc : int * int) -> + (loc : Lexing.position * Lexing.position) -> (let _ = warn_antiq loc "3.06+18" in Qast.Node ("CrVal", [Qast.Loc; lab; antiquot "mut" loc mf; e]) : 'class_str_item)); @@ -4195,7 +4720,8 @@ Grammar.extend (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) -> + (fun (pb : string) (ce : 'class_expr) _ + (loc : Lexing.position * Lexing.position) -> (let _ = warn_antiq loc "3.06+18" in Qast.Node ("CrInh", [Qast.Loc; ce; antiquot "as" loc pb]) : 'class_str_item))]]; @@ -4207,7 +4733,8 @@ Grammar.extend Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : string) _ (loc : int * int) -> + (fun (t : 'ctyp) _ (l : 'label) (mf : string) _ + (loc : Lexing.position * Lexing.position) -> (let _ = warn_antiq loc "3.06+18" in Qast.Node ("CgVal", [Qast.Loc; l; antiquot "mut" loc mf; t]) : 'class_sig_item))]]]);; @@ -4229,7 +4756,8 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))], Gramext.action - (fun (dp : 'dir_param) (n : 'a_LIDENT) _ (loc : int * int) -> + (fun (dp : 'dir_param) (n : 'a_LIDENT) _ + (loc : Lexing.position * Lexing.position) -> (Qast.Node ("StDir", [Qast.Loc; n; dp]) : 'str_item))]]; Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, [None, None, @@ -4239,20 +4767,22 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))], Gramext.action - (fun (dp : 'dir_param) (n : 'a_LIDENT) _ (loc : int * int) -> + (fun (dp : 'dir_param) (n : 'a_LIDENT) _ + (loc : Lexing.position * Lexing.position) -> (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)); + (fun (loc : Lexing.position * Lexing.position) -> + (Qast.Option None : 'dir_param)); [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], Gramext.action - (fun (e : 'expr) (loc : int * int) -> + (fun (e : 'expr) (loc : Lexing.position * Lexing.position) -> (Qast.Option (Some e) : 'dir_param)); [Gramext.Stoken ("ANTIQUOT", "opt")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "opt" loc a : 'dir_param))]]]);; (* Antiquotations *) @@ -4263,44 +4793,44 @@ Grammar.extend [None, None, [[Gramext.Stoken ("ANTIQUOT", "")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "" loc a : 'module_expr)); [Gramext.Stoken ("ANTIQUOT", "mexp")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "" loc a : 'str_item)); [Gramext.Stoken ("ANTIQUOT", "stri")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "" loc a : 'module_type)); [Gramext.Stoken ("ANTIQUOT", "mtyp")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "" loc a : 'sig_item)); [Gramext.Stoken ("ANTIQUOT", "sigi")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "sigi" loc a : 'sig_item))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -4309,18 +4839,19 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (el : 'a_list) _ (loc : int * int) -> + (fun _ (el : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExTup", [Qast.Loc; el]) : 'expr)); [Gramext.Stoken ("ANTIQUOT", "anti")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "" loc a : 'expr)); [Gramext.Stoken ("ANTIQUOT", "exp")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "exp" loc a : 'expr))]]; Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -4329,18 +4860,19 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (pl : 'a_list) _ (loc : int * int) -> + (fun _ (pl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaTup", [Qast.Loc; pl]) : 'patt)); [Gramext.Stoken ("ANTIQUOT", "anti")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "" loc a : 'patt)); [Gramext.Stoken ("ANTIQUOT", "pat")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "pat" loc a : 'patt))]]; Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, [None, None, @@ -4348,18 +4880,19 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (pl : 'a_list) _ (loc : int * int) -> + (fun _ (pl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("PaTup", [Qast.Loc; pl]) : 'ipatt)); [Gramext.Stoken ("ANTIQUOT", "anti")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "" loc a : 'ipatt)); [Gramext.Stoken ("ANTIQUOT", "pat")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "pat" loc a : 'ipatt))]]; Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -4368,39 +4901,40 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); Gramext.Stoken ("", ")")], Gramext.action - (fun _ (tl : 'a_list) _ (loc : int * int) -> + (fun _ (tl : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("TyTup", [Qast.Loc; tl]) : 'ctyp)); [Gramext.Stoken ("ANTIQUOT", "")], Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'ctyp)); + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "" loc a : 'ctyp)); [Gramext.Stoken ("ANTIQUOT", "typ")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "" loc a : 'class_type))]]; Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -4409,7 +4943,7 @@ Grammar.extend Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); Gramext.Stoken ("", ">}")], Gramext.action - (fun _ (fel : 'a_list) _ (loc : int * int) -> + (fun _ (fel : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr))]]; Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), Some (Gramext.Level "simple"), @@ -4417,125 +4951,179 @@ Grammar.extend [[Gramext.Stoken ("", "#"); Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], Gramext.action - (fun (a : 'a_list) _ (loc : int * int) -> + (fun (a : 'a_list) _ (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str i : 'a_UIDENT)); [Gramext.Stoken ("ANTIQUOT", "")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "" loc a : 'a_UIDENT)); [Gramext.Stoken ("ANTIQUOT", "uid")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (i : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str i : 'a_LIDENT)); [Gramext.Stoken ("ANTIQUOT", "")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "" loc a : 'a_LIDENT)); [Gramext.Stoken ("ANTIQUOT", "lid")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (s : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str s : 'a_INT)); [Gramext.Stoken ("ANTIQUOT", "")], Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_INT)); + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "" loc a : 'a_INT)); [Gramext.Stoken ("ANTIQUOT", "int")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "int" loc a : 'a_INT))]]; + Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("INT32", "")], + Gramext.action + (fun (s : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str s : 'a_INT32)); + [Gramext.Stoken ("ANTIQUOT", "")], + Gramext.action + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "" loc a : 'a_INT32)); + [Gramext.Stoken ("ANTIQUOT", "int32")], + Gramext.action + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "int32" loc a : 'a_INT32))]]; + Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("INT64", "")], + Gramext.action + (fun (s : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str s : 'a_INT64)); + [Gramext.Stoken ("ANTIQUOT", "")], + Gramext.action + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "" loc a : 'a_INT64)); + [Gramext.Stoken ("ANTIQUOT", "int64")], + Gramext.action + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "int64" loc a : 'a_INT64))]]; + Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e), None, + [None, None, + [[Gramext.Stoken ("NATIVEINT", "")], + Gramext.action + (fun (s : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str s : 'a_NATIVEINT)); + [Gramext.Stoken ("ANTIQUOT", "")], + Gramext.action + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "" loc a : 'a_NATIVEINT)); + [Gramext.Stoken ("ANTIQUOT", "nativeint")], + Gramext.action + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "nativeint" loc a : 'a_NATIVEINT))]]; 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)); + (fun (s : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str s : 'a_FLOAT)); [Gramext.Stoken ("ANTIQUOT", "")], Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_FLOAT)); + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "" loc a : 'a_FLOAT)); [Gramext.Stoken ("ANTIQUOT", "flo")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (s : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str s : 'a_STRING)); [Gramext.Stoken ("ANTIQUOT", "")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (antiquot "" loc a : 'a_STRING)); [Gramext.Stoken ("ANTIQUOT", "str")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (s : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str s : 'a_CHAR)); [Gramext.Stoken ("ANTIQUOT", "")], Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_CHAR)); + (fun (a : string) (loc : Lexing.position * Lexing.position) -> + (antiquot "" loc a : 'a_CHAR)); [Gramext.Stoken ("ANTIQUOT", "chr")], Gramext.action - (fun (a : string) (loc : int * int) -> + (fun (a : string) (loc : Lexing.position * Lexing.position) -> (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)); + (fun (s : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str s : 'a_TILDEIDENT)); [Gramext.Stoken ("", "~"); Gramext.Stoken ("ANTIQUOT", "")], Gramext.action - (fun (a : string) _ (loc : int * int) -> + (fun (a : string) _ (loc : Lexing.position * Lexing.position) -> (antiquot "" loc a : 'a_TILDEIDENT))]]; Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("LABEL", "")], Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_LABEL))]]; + (fun (s : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str s : 'a_LABEL))]]; Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("QUESTIONIDENT", "")], Gramext.action - (fun (s : string) (loc : int * int) -> + (fun (s : string) (loc : Lexing.position * Lexing.position) -> (Qast.Str s : 'a_QUESTIONIDENT)); [Gramext.Stoken ("", "?"); Gramext.Stoken ("ANTIQUOT", "")], Gramext.action - (fun (a : string) _ (loc : int * int) -> + (fun (a : string) _ (loc : Lexing.position * Lexing.position) -> (antiquot "" loc a : 'a_QUESTIONIDENT))]]; Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e), None, [None, None, [[Gramext.Stoken ("OPTLABEL", "")], Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_OPTLABEL))]]];; + (fun (s : string) (loc : Lexing.position * Lexing.position) -> + (Qast.Str s : 'a_OPTLABEL))]]];; let apply_entry e = let f s = Grammar.Entry.parse e (Stream.of_string s) in @@ -4551,7 +5139,8 @@ Grammar.extend (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))]]]; + (fun _ (x : 'sig_item) (loc : Lexing.position * Lexing.position) -> + (x : 'sig_item_eoi))]]]; Quotation.add "sig_item" (apply_entry sig_item_eoi);; let str_item_eoi = Grammar.Entry.create gram "structure item" in @@ -4562,7 +5151,8 @@ Grammar.extend (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))]]]; + (fun _ (x : 'str_item) (loc : Lexing.position * Lexing.position) -> + (x : 'str_item_eoi))]]]; Quotation.add "str_item" (apply_entry str_item_eoi);; let ctyp_eoi = Grammar.Entry.create gram "type" in @@ -4572,7 +5162,8 @@ Grammar.extend [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'ctyp) (loc : int * int) -> (x : 'ctyp_eoi))]]]; + (fun _ (x : 'ctyp) (loc : Lexing.position * Lexing.position) -> + (x : 'ctyp_eoi))]]]; Quotation.add "ctyp" (apply_entry ctyp_eoi);; let patt_eoi = Grammar.Entry.create gram "pattern" in @@ -4582,7 +5173,8 @@ Grammar.extend [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'patt) (loc : int * int) -> (x : 'patt_eoi))]]]; + (fun _ (x : 'patt) (loc : Lexing.position * Lexing.position) -> + (x : 'patt_eoi))]]]; Quotation.add "patt" (apply_entry patt_eoi);; let expr_eoi = Grammar.Entry.create gram "expression" in @@ -4592,7 +5184,8 @@ Grammar.extend [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'expr) (loc : int * int) -> (x : 'expr_eoi))]]]; + (fun _ (x : 'expr) (loc : Lexing.position * Lexing.position) -> + (x : 'expr_eoi))]]]; Quotation.add "expr" (apply_entry expr_eoi);; let module_type_eoi = Grammar.Entry.create gram "module type" in @@ -4604,7 +5197,7 @@ Grammar.extend (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'module_type) (loc : int * int) -> + (fun _ (x : 'module_type) (loc : Lexing.position * Lexing.position) -> (x : 'module_type_eoi))]]]; Quotation.add "module_type" (apply_entry module_type_eoi);; @@ -4617,7 +5210,7 @@ Grammar.extend (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'module_expr) (loc : int * int) -> + (fun _ (x : 'module_expr) (loc : Lexing.position * Lexing.position) -> (x : 'module_expr_eoi))]]]; Quotation.add "module_expr" (apply_entry module_expr_eoi);; @@ -4629,7 +5222,7 @@ Grammar.extend (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'class_type) (loc : int * int) -> + (fun _ (x : 'class_type) (loc : Lexing.position * Lexing.position) -> (x : 'class_type_eoi))]]]; Quotation.add "class_type" (apply_entry class_type_eoi);; @@ -4641,7 +5234,7 @@ Grammar.extend (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'class_expr) (loc : int * int) -> + (fun _ (x : 'class_expr) (loc : Lexing.position * Lexing.position) -> (x : 'class_expr_eoi))]]]; Quotation.add "class_expr" (apply_entry class_expr_eoi);; @@ -4656,7 +5249,8 @@ Grammar.extend (class_sig_item : 'class_sig_item Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'class_sig_item) (loc : int * int) -> + (fun _ (x : 'class_sig_item) + (loc : Lexing.position * Lexing.position) -> (x : 'class_sig_item_eoi))]]]; Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi);; @@ -4671,7 +5265,8 @@ Grammar.extend (class_str_item : 'class_str_item Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'class_str_item) (loc : int * int) -> + (fun _ (x : 'class_str_item) + (loc : Lexing.position * Lexing.position) -> (x : 'class_str_item_eoi))]]]; Quotation.add "class_str_item" (apply_entry class_str_item_eoi);; @@ -4684,7 +5279,7 @@ Grammar.extend (Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e)); Gramext.Stoken ("EOI", "")], Gramext.action - (fun _ (x : 'with_constr) (loc : int * int) -> + (fun _ (x : 'with_constr) (loc : Lexing.position * Lexing.position) -> (x : 'with_constr_eoi))]]]; Quotation.add "with_constr" (apply_entry with_constr_eoi);; @@ -4696,5 +5291,6 @@ Grammar.extend (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))]]]; + (fun _ (x : 'row_field) (loc : Lexing.position * Lexing.position) -> + (x : 'row_field_eoi))]]]; Quotation.add "row_field" (apply_entry row_field_eoi);; diff --git a/camlp4/ocaml_src/odyl/.depend b/camlp4/ocaml_src/odyl/.depend index 7823dd01..c09099d3 100644 --- a/camlp4/ocaml_src/odyl/.depend +++ b/camlp4/ocaml_src/odyl/.depend @@ -1,6 +1,4 @@ +odyl_main.cmo: odyl_config.cmo odyl_main.cmi +odyl_main.cmx: odyl_config.cmx odyl_main.cmi odyl.cmo: odyl_config.cmo odyl_main.cmi odyl.cmx: odyl_config.cmx odyl_main.cmx -odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \ - odyl_main.cmi -odyl_main.cmx: odyl_config.cmx \ - odyl_main.cmi diff --git a/camlp4/ocaml_src/odyl/Makefile b/camlp4/ocaml_src/odyl/Makefile index bd59608b..07d5c6b2 100644 --- a/camlp4/ocaml_src/odyl/Makefile +++ b/camlp4/ocaml_src/odyl/Makefile @@ -12,22 +12,34 @@ OBJS=odyl_config.cmo odyl_main.cmo all: odyl$(EXE) -opt: odyl.cmxa odyl.cmx +opt: opt$(PROFILING) + +optnoprof: odyl.cmx odyl.cmxa + +optprof: optnoprof odyl.p.cmx odyl.p.cmxa odyl$(EXE): odyl.cma odyl.cmo - $(OCAMLC) odyl.cma odyl.cmo -o odyl$(EXE) + $(OCAMLC) odyl.cma odyl.cmo -o $@ odyl.cma: $(OBJS) - $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o odyl.cma + $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o $@ odyl.cmxa: $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o odyl.cmxa + $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o $@ + +odyl.p.cmxa: $(OBJS:.cmo=.p.cmx) + $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.p.cmx) -a -o $@ odyl_main.cmx: odyl_main.ml $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml $(OCAMLOPT) -c -impl odyl_main.ppo rm -f odyl_main.ppo +odyl_main.p.cmx: odyl_main.ml + $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml + $(OCAMLOPT) -p -c -o $@ -impl odyl_main.ppo + rm -f odyl_main.ppo + odyl_config.ml: (echo 'let standard_library ='; \ echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \ @@ -56,6 +68,8 @@ compare: install: -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/. - if test -f odyl.cmxa; then cp odyl.cmxa odyl.$(A) $(LIBDIR)/camlp4/.; fi + for f in odyl.$(A) odyl.p.$(A) odyl.cmx odyl.o odyl.p.cmx odyl.p.o odyl.cmxa odyl.p.cmxa ; do \ + test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true; \ + done include .depend diff --git a/camlp4/ocaml_src/odyl/Makefile.Mac b/camlp4/ocaml_src/odyl/Makefile.Mac deleted file mode 100644 index 41b16d30..00000000 --- a/camlp4/ocaml_src/odyl/Makefile.Mac +++ /dev/null @@ -1,49 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} - -OBJS = odyl_config.cmo odyl_main.cmo - -all Ä odyl - -odyl Ä odyl.cma odyl.cmo - {OCAMLC} odyl.cma odyl.cmo -o odyl - -odyl.cma Ä {OBJS} - {OCAMLC} {LINKFLAGS} dynlink.cma {OBJS} -a -o odyl.cma - -odyl_config.cmo Ä - echo 'let standard_library =' > odyl_config.ml - echo ' try Sys.getenv "CAMLP4LIB" with' >> odyl_config.ml - echo ' Not_found -> "'{P4LIBDIR}'"' >> odyl_config.ml - {OCAMLC} {OCAMLCFLAGS} -c odyl_config.ml - -clean ÄÄ - delete -i odyl_config.ml odyl - -{dependrule} - -promote Ä $OutOfDate - -compare Ä $OutOfDate - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y odyl.cmo odyl.cma "{P4LIBDIR}" - duplicate -y odyl "{BINDIR}" - -{defrules} diff --git a/camlp4/ocaml_src/odyl/Makefile.Mac.depend b/camlp4/ocaml_src/odyl/Makefile.Mac.depend deleted file mode 100644 index adaff277..00000000 --- a/camlp4/ocaml_src/odyl/Makefile.Mac.depend +++ /dev/null @@ -1,4 +0,0 @@ -odyl_main.cmoÄ odyl_config.cmo odyl_main.cmi -odyl_main.cmxÄ odyl_config.cmx odyl_main.cmi -odyl.cmoÄ odyl_config.cmo odyl_main.cmi -odyl.cmxÄ odyl_config.cmx odyl_main.cmx diff --git a/camlp4/ocaml_src/odyl/odyl.ml b/camlp4/ocaml_src/odyl/odyl.ml index 096e13ee..d5b6a6ce 100644 --- a/camlp4/ocaml_src/odyl/odyl.ml +++ b/camlp4/ocaml_src/odyl/odyl.ml @@ -27,6 +27,10 @@ let apply_load () = flush stdout; exit 0 end + else if s = "-version" then + begin + print_string Sys.ocaml_version; print_newline (); flush stdout; exit 0 + end else if s = "--" then begin incr i; stop := true; () end else if String.length s > 0 && s.[0] == '-' then stop := true else if diff --git a/camlp4/ocaml_src/odyl/odyl_main.ml b/camlp4/ocaml_src/odyl/odyl_main.ml index 22e5e65d..a048f1b0 100644 --- a/camlp4/ocaml_src/odyl/odyl_main.ml +++ b/camlp4/ocaml_src/odyl/odyl_main.ml @@ -20,8 +20,7 @@ let first_arg_no_load () = if i < Array.length Sys.argv then match Sys.argv.(i) with "-I" -> loop (i + 2) - | "-nolib" -> loop (i + 1) - | "-where" -> loop (i + 1) + | "-nolib" | "-where" | "-version" -> loop (i + 1) | "--" -> i + 1 | s -> if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" diff --git a/camlp4/ocpp/Makefile b/camlp4/ocpp/Makefile index af4a11f5..22d3c6d5 100644 --- a/camlp4/ocpp/Makefile +++ b/camlp4/ocpp/Makefile @@ -1,4 +1,4 @@ -# $Id: Makefile,v 1.5 2003/07/10 12:28:33 michel Exp $ +# $Id: Makefile,v 1.6 2004/05/12 15:22:48 mauny Exp $ include ../config/Makefile @@ -12,7 +12,7 @@ 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) + $(OCAMLC) $(LINKFLAGS) ../boot/stdpp.cmo ../camlp4/reloc.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) diff --git a/camlp4/ocpp/Makefile.Mac b/camlp4/ocpp/Makefile.Mac deleted file mode 100644 index 0a737ed5..00000000 --- a/camlp4/ocpp/Makefile.Mac +++ /dev/null @@ -1,41 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: 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 index e62f689a..c72cd96b 100644 --- a/camlp4/ocpp/ocpp.ml +++ b/camlp4/ocpp/ocpp.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ocpp.ml,v 1.5 2003/07/10 12:28:33 michel Exp $ *) +(* $Id: ocpp.ml,v 1.6 2004/05/12 15:22:48 mauny Exp $ *) value buff = ref (String.create 80); value store len x = @@ -46,7 +46,16 @@ and inside_locate cs = | [: :] -> raise (Stream.Error "end of file in locate directive") ] ; +value nowhere = { + Lexing.pos_fname = ""; + Lexing.pos_lnum = 0; + Lexing.pos_bol = 0; + Lexing.pos_cnum = 0 +} +; + value quot name pos str = + let pos = Reloc.shift_pos pos nowhere in let exp = try match Quotation.find name with @@ -54,13 +63,13 @@ value quot name pos str = | _ -> raise Not_found ] with [ Not_found -> - Stdpp.raise_with_loc (pos, pos + String.length str) Not_found ] + Stdpp.raise_with_loc (pos, Reloc.shift_pos (String.length str) pos) 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 ] + Stdpp.raise_with_loc (Reloc.adjust_loc pos (p1, p2)) exc + | exc -> Stdpp.raise_with_loc (pos, Reloc.shift_pos (String.length str) pos) exc ] in let cs = Stream.of_string new_str in copy_strip_locate cs ; diff --git a/camlp4/odyl/.depend b/camlp4/odyl/.depend index 7823dd01..3f125b7d 100644 --- a/camlp4/odyl/.depend +++ b/camlp4/odyl/.depend @@ -1,6 +1,4 @@ odyl.cmo: odyl_config.cmo odyl_main.cmi odyl.cmx: odyl_config.cmx odyl_main.cmx -odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \ - odyl_main.cmi -odyl_main.cmx: odyl_config.cmx \ - odyl_main.cmi +odyl_main.cmo: odyl_config.cmo odyl_main.cmi +odyl_main.cmx: odyl_config.cmx odyl_main.cmi diff --git a/camlp4/odyl/Makefile b/camlp4/odyl/Makefile index 23a90d3c..f9808ad9 100644 --- a/camlp4/odyl/Makefile +++ b/camlp4/odyl/Makefile @@ -1,4 +1,4 @@ -# $Id: Makefile,v 1.15 2003/08/29 12:15:15 xleroy Exp $ +# $Id: Makefile,v 1.15.4.5 2004/07/02 14:43:31 mauny Exp $ include ../config/Makefile @@ -12,22 +12,34 @@ OBJS=odyl_config.cmo odyl_main.cmo all: odyl$(EXE) -opt: odyl.cmxa odyl.cmx +opt: opt$(PROFILING) + +optnoprof: odyl.cmx odyl.cmxa + +optprof: optnoprof odyl.p.cmx odyl.p.cmxa odyl$(EXE): odyl.cma odyl.cmo - $(OCAMLC) odyl.cma odyl.cmo -o odyl$(EXE) + $(OCAMLC) odyl.cma odyl.cmo -o $@ odyl.cma: $(OBJS) - $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o odyl.cma + $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o $@ odyl.cmxa: $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o odyl.cmxa + $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o $@ + +odyl.p.cmxa: $(OBJS:.cmo=.p.cmx) + $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.p.cmx) -a -o $@ odyl_main.cmx: odyl_main.ml $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml $(OCAMLOPT) -c -impl odyl_main.ppo rm -f odyl_main.ppo +odyl_main.p.cmx: odyl_main.ml + $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml + $(OCAMLOPT) -p -c -o $@ -impl odyl_main.ppo + rm -f odyl_main.ppo + odyl_config.ml: (echo 'let standard_library ='; \ echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \ @@ -56,6 +68,8 @@ compare: install: -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/. - if test -f odyl.cmxa; then cp odyl.cmxa odyl.$(A) $(LIBDIR)/camlp4/.; fi + for f in odyl.$(A) odyl.p.$(A) odyl.cmx odyl.o odyl.p.cmx odyl.p.o odyl.cmxa odyl.p.cmxa ; do \ + test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true; \ + done include .depend diff --git a/camlp4/odyl/Makefile.Mac b/camlp4/odyl/Makefile.Mac deleted file mode 100644 index 9664fe84..00000000 --- a/camlp4/odyl/Makefile.Mac +++ /dev/null @@ -1,49 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: 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 deleted file mode 100644 index adaff277..00000000 --- a/camlp4/odyl/Makefile.Mac.depend +++ /dev/null @@ -1,4 +0,0 @@ -odyl_main.cmoÄ odyl_config.cmo odyl_main.cmi -odyl_main.cmxÄ odyl_config.cmx odyl_main.cmi -odyl.cmoÄ odyl_config.cmo odyl_main.cmi -odyl.cmxÄ odyl_config.cmx odyl_main.cmx diff --git a/camlp4/odyl/odyl.ml b/camlp4/odyl/odyl.ml index 7e895eb1..c8b133b8 100644 --- a/camlp4/odyl/odyl.ml +++ b/camlp4/odyl/odyl.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: odyl.ml,v 1.2 2002/07/19 14:53:56 mauny Exp $ *) +(* $Id: odyl.ml,v 1.2.6.1 2004/06/23 13:31:38 mauny Exp $ *) value apply_load () = let i = ref 1 in @@ -28,6 +28,12 @@ value apply_load () = flush stdout; exit 0 } + else if s = "-version" then do { + print_string Sys.ocaml_version; + print_newline (); + flush stdout; + exit 0 + } else if s = "--" then do { incr i; stop.val := True; () } else if String.length s > 0 && s.[0] == '-' then stop.val := True else if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" diff --git a/camlp4/odyl/odyl_main.ml b/camlp4/odyl/odyl_main.ml index 66c236c5..3dd80e28 100644 --- a/camlp4/odyl/odyl_main.ml +++ b/camlp4/odyl/odyl_main.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: odyl_main.ml,v 1.4 2003/07/10 12:28:34 michel Exp $ *) +(* $Id: odyl_main.ml,v 1.4.4.1 2004/06/23 14:43:58 mauny Exp $ *) value go = ref (fun () -> ()); value name = ref "odyl"; @@ -20,12 +20,12 @@ value first_arg_no_load () = if i < Array.length Sys.argv then match Sys.argv.(i) with [ "-I" -> loop (i + 2) - | "-nolib" -> loop (i + 1) - | "-where" -> loop (i + 1) + | ("-nolib" | "-where" | "-version") -> loop (i + 1) | "--" -> i + 1 | s -> if Filename.check_suffix s ".cmo" - || Filename.check_suffix s ".cma" then loop (i + 1) + || Filename.check_suffix s ".cma" + then loop (i + 1) else i ] else i ; diff --git a/camlp4/tools/apply.sh b/camlp4/tools/apply.sh index a0bebbe2..4a22a92f 100755 --- a/camlp4/tools/apply.sh +++ b/camlp4/tools/apply.sh @@ -1,28 +1,33 @@ #!/bin/sh -# $Id: apply.sh,v 1.2 2002/07/23 14:11:49 doligez Exp $ +# $Id: apply.sh,v 1.4.4.1 2004/07/07 16:22:26 mauny Exp $ +P4TOP=.. ARGS1= FILE= while test "" != "$1"; do case $1 in *.ml*) FILE=$1;; + -top) P4TOP="$2"; shift;; *) ARGS1="$ARGS1 $1";; esac shift done -head -1 $FILE >/dev/null || exit 1 +# FILE must exist and be non empty (at least one line) +test -s "$FILE" || exit 1 -set - `head -1 $FILE` + + +set - `awk 'NR == 1' "$FILE"` if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="../boot/$2 -nolib -I ../boot -I ../etc" + COMM="$P4TOP/boot/$2 -nolib -I $P4TOP/boot -I $P4TOP/etc" shift; shift ARGS2=`echo $* | sed -e "s/[()*]//g"` else - COMM="../boot/camlp4 -nolib -I ../boot -I ../etc pa_o.cmo" + COMM="$P4TOP/boot/camlp4 -nolib -I $P4TOP/boot -I $P4TOP/etc pa_o.cmo" ARGS2= fi -OTOP=../.. +OTOP=$P4TOP/.. echo $OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE 1>&2 $OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE diff --git a/camlp4/tools/camlp4_comm.sh b/camlp4/tools/camlp4_comm.sh index bc79f149..3800beaf 100755 --- a/camlp4/tools/camlp4_comm.sh +++ b/camlp4/tools/camlp4_comm.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: camlp4_comm.sh,v 1.7 2003/07/10 12:28:35 michel Exp $ +# $Id: camlp4_comm.sh,v 1.9 2004/05/12 15:22:48 mauny Exp $ ARGS1= FILE= @@ -13,9 +13,10 @@ while test "" != "$1"; do shift done -head -1 $FILE >/dev/null || exit 1 +# FILE must exist and be non empty (at least one line) +test -s "$FILE" || exit 1 -set - `head -1 $FILE` +set - `awk 'NR == 1' "$FILE"` if test "$2" = "camlp4r" -o "$2" = "camlp4"; then COMM="ocamlrun$EXE ../boot/$2$EXE -nolib -I ../boot" if test "`basename $OTOP`" != "ocaml_stuff"; then @@ -23,7 +24,7 @@ if test "$2" = "camlp4r" -o "$2" = "camlp4"; then fi shift; shift ARGS2=`echo $* | sed -e "s/[()*]//g"` -# ARGS1="$ARGS1 -verbose" + ARGS1="$ARGS1 -verbose" if test "$QUIET" = "no"; then echo $COMM $ARGS2 $ARGS1 $FILE; fi $COMM $ARGS2 $ARGS1 $FILE else diff --git a/camlp4/tools/conv.sh b/camlp4/tools/conv.sh index 98ba728f..64a4e2b1 100755 --- a/camlp4/tools/conv.sh +++ b/camlp4/tools/conv.sh @@ -11,7 +11,7 @@ while test "" != "$1"; do shift done -set - `head -1 $FILE` +set - `awk 'NR == 1' "$FILE"` if test "$2" = "camlp4r" -o "$2" = "camlp4"; then COMM="$OTOP/boot/ocamlrun $DIR/../boot/$2 -nolib -I $DIR/../boot $INCL $DIR/../etc/pr_o.cmo" shift; shift diff --git a/camlp4/top/Makefile b/camlp4/top/Makefile index b8851f07..b037243c 100644 --- a/camlp4/top/Makefile +++ b/camlp4/top/Makefile @@ -1,19 +1,18 @@ -# $Id: Makefile,v 1.11 2003/07/10 12:28:35 michel Exp $ +# $Id: Makefile,v 1.12.2.1 2004/07/09 15:10:57 mauny 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 +CAMLP4_OBJS=$(OTOP)/utils/config.cmo ../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo ../camlp4/quotation.cmo ../camlp4/reloc.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo ../camlp4/ast2pt.cmo TOP=camlp4_top.cmo ROBJS=$(CAMLP4_OBJS) ../meta/pa_r.cmo ../meta/pa_rp.cmo rprint.cmo $(TOP) -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 +OBJS=$(OTOP)/utils/config.cmo ../camlp4/quotation.cmo ../camlp4/reloc.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo ../camlp4/ast2pt.cmo camlp4_top.cmo -TARGET=camlp4o.cma camlp4r.cma camlp4sch.cma camlp4_top.cma +TARGET=camlp4o.cma camlp4r.cma camlp4_top.cma all: $(TARGET) @@ -26,9 +25,6 @@ camlp4o.cma: $(OOBJS) camlp4r.cma: $(ROBJS) $(OCAMLC) $(ROBJS) -linkall -a -o camlp4r.cma -camlp4sch.cma: $(SOBJS) - $(OCAMLC) $(SOBJS) -linkall -a -o camlp4sch.cma - camlp4_top.cma: $(OBJS) $(OCAMLC) $(OBJS) -a -o camlp4_top.cma diff --git a/camlp4/top/Makefile.Mac b/camlp4/top/Makefile.Mac deleted file mode 100644 index 292d66b0..00000000 --- a/camlp4/top/Makefile.Mac +++ /dev/null @@ -1,60 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: 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 deleted file mode 100644 index 6b7096da..00000000 --- a/camlp4/top/Makefile.Mac.depend +++ /dev/null @@ -1,2 +0,0 @@ -camlp4_top.cmoÄ ::camlp4:ast2pt.cmo ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -camlp4_top.cmxÄ ::camlp4:ast2pt.cmx ::camlp4:mLast.cmi ::camlp4:pcaml.cmx diff --git a/camlp4/top/camlp4_top.ml b/camlp4/top/camlp4_top.ml index 9c6663ac..4f6931a6 100644 --- a/camlp4/top/camlp4_top.ml +++ b/camlp4/top/camlp4_top.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: camlp4_top.ml,v 1.12 2002/09/09 14:22:27 guesdon Exp $ *) +(* $Id: camlp4_top.ml,v 1.13 2004/05/12 15:22:48 mauny Exp $ *) open Parsetree; open Lexing; @@ -59,8 +59,9 @@ value highlight_locations lb loc1 loc2 = 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) + highlight_locations lb ((fst loc).Lexing.pos_cnum, (snd loc).Lexing.pos_cnum) (-1, -1) + else Toploop.print_location Format.err_formatter + (Ast2pt.mkloc loc) ; value wrap f shfn lb = diff --git a/camlp4/top/rprint.ml b/camlp4/top/rprint.ml index 573e6246..77fc1919 100644 --- a/camlp4/top/rprint.ml +++ b/camlp4/top/rprint.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: rprint.ml,v 1.12 2003/09/23 12:52:34 mauny Exp $ *) +(* $Id: rprint.ml,v 1.14 2004/06/12 08:55:46 xleroy Exp $ *) open Format; open Outcometree; @@ -167,8 +167,8 @@ and print_simple_out_type ppf = | 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 "< " + 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 @@ -313,12 +313,14 @@ and print_out_signature ppf = 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@]" + [ Osig_class vir_flag name params clt rs -> + fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" + (if rs = Orec_next then "and" else "class") (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@]" + | Osig_class_type vir_flag name params clt rs -> + fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" + (if rs = Orec_next then "and" else "class type") (if vir_flag then " virtual" else "") print_out_class_params params name Toploop.print_out_class_type.val clt | Osig_exception id tyl -> @@ -328,10 +330,16 @@ and print_out_sig_item ppf = | 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 + | Osig_module name mty rs -> + fprintf ppf "@[<2>%s %s :@ %a@]" name + (match rs with [ Orec_not -> "module" + | Orec_first -> "module rec" + | Orec_next -> "and" ]) Toploop.print_out_module_type.val mty - | Osig_type tdl -> print_out_type_decl_list ppf tdl + | Osig_type td rs -> + print_out_type_decl + (if rs = Orec_next then "and" else "type") + ppf td | Osig_value name ty prims -> let kwd = if prims = [] then "value" else "external" in let pr_prims ppf = @@ -345,16 +353,7 @@ and print_out_sig_item ppf = 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 diff --git a/camlp4/unmaintained/Makefile b/camlp4/unmaintained/Makefile new file mode 100644 index 00000000..9b0bc828 --- /dev/null +++ b/camlp4/unmaintained/Makefile @@ -0,0 +1,38 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# The unmaintained directory +# + +DIRS=format lefteval ocamllex olabl scheme sml + +all: + for dir in $(DIRS); do \ + cd $$dir && $(MAKE) all && cd .. ; \ + done + +opt: + for dir in $(DIRS); do \ + cd $$dir && $(MAKE) opt && cd .. ; \ + done + +depend: + for dir in $(DIRS); do \ + cd $$dir && $(MAKE) depend && cd .. ; \ + done + +clean: + for dir in $(DIRS); do \ + cd $$dir && $(MAKE) clean && cd .. ; \ + done + +install: diff --git a/camlp4/unmaintained/format/.depend b/camlp4/unmaintained/format/.depend new file mode 100644 index 00000000..e69de29b diff --git a/camlp4/unmaintained/format/Makefile b/camlp4/unmaintained/format/Makefile new file mode 100644 index 00000000..c3887209 --- /dev/null +++ b/camlp4/unmaintained/format/Makefile @@ -0,0 +1,61 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_format +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. +CAMLP4=../../camlp4/camlp4$(EXE) + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) + +P4INCLUDES= -nolib -I ../../lib -I ../../meta -I ../../etc +OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../lib -I ../../camlp4 +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SRC=pa_format.ml +OBJS=$(SRC:.ml=.cmo) +OBJSX=$(SRC:.ml=.cmx) + +all: $(OBJS) + +opt: $(OBJSX) + +depend: + cp .depend .depend.bak + > .depend + for file in $(SRC); do \ + $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ + sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ + done + +clean: + rm -f *.cm* *.$(O) *.bak .*.bak + + +.SUFFIXES: .cmx .cmo .cmi .ml .mli + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +include .depend diff --git a/camlp4/unmaintained/format/README b/camlp4/unmaintained/format/README new file mode 100644 index 00000000..809d42f2 --- /dev/null +++ b/camlp4/unmaintained/format/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/camlp4/etc/pa_format.ml b/camlp4/unmaintained/format/pa_format.ml similarity index 54% rename from camlp4/etc/pa_format.ml rename to camlp4/unmaintained/format/pa_format.ml index 776e4ba8..040cb6ab 100644 --- a/camlp4/etc/pa_format.ml +++ b/camlp4/unmaintained/format/pa_format.ml @@ -1,5 +1,18 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id: pa_format.ml,v 1.2 2002/07/19 14:53:45 mauny Exp $ *) +(* pa_r.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* 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 GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(***********************************************************************) +(* $Id: pa_format.ml,v 1.1.2.1 2004/07/07 16:22:27 mauny Exp $ *) open Pcaml; diff --git a/camlp4/unmaintained/lefteval/.depend b/camlp4/unmaintained/lefteval/.depend new file mode 100644 index 00000000..e69de29b diff --git a/camlp4/unmaintained/lefteval/Makefile b/camlp4/unmaintained/lefteval/Makefile new file mode 100644 index 00000000..7e5cdd02 --- /dev/null +++ b/camlp4/unmaintained/lefteval/Makefile @@ -0,0 +1,61 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_lefteval +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. +CAMLP4=../../camlp4/camlp4$(EXE) + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) + +P4INCLUDES= -nolib -I ../../meta -I ../../etc +OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SRC=pa_lefteval.ml +OBJS=$(SRC:.ml=.cmo) +OBJSX=$(SRC:.ml=.cmx) + +all: $(OBJS) + +opt: $(OBJSX) + +depend: + cp .depend .depend.bak + > .depend + for file in $(SRC); do \ + $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ + sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ + done + +clean: + rm -f *.cm* *.$(O) *.bak .*.bak + + +.SUFFIXES: .cmx .cmo .cmi .ml .mli + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +include .depend diff --git a/camlp4/unmaintained/lefteval/README b/camlp4/unmaintained/lefteval/README new file mode 100644 index 00000000..809d42f2 --- /dev/null +++ b/camlp4/unmaintained/lefteval/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/camlp4/etc/pa_lefteval.ml b/camlp4/unmaintained/lefteval/pa_lefteval.ml similarity index 94% rename from camlp4/etc/pa_lefteval.ml rename to camlp4/unmaintained/lefteval/pa_lefteval.ml index 533a58f8..ee1280f9 100644 --- a/camlp4/etc/pa_lefteval.ml +++ b/camlp4/unmaintained/lefteval/pa_lefteval.ml @@ -1,16 +1,18 @@ -(* camlp4r q_MLast.cmo *) +(* pa_r.cmo q_MLast.cmo pr_dump.cmo *) (***********************************************************************) (* *) -(* Camlp4 *) +(* Camlp4 *) (* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) +(* en Automatique. All 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: pa_lefteval.ml,v 1.2 2003/07/10 12:28:20 michel Exp $ *) +(* $Id: pa_lefteval.ml,v 1.1.2.1 2004/07/07 16:22:28 mauny Exp $ *) value not_impl name x = let desc = diff --git a/camlp4/unmaintained/ocamllex/Makefile b/camlp4/unmaintained/ocamllex/Makefile new file mode 100644 index 00000000..b232023e --- /dev/null +++ b/camlp4/unmaintained/ocamllex/Makefile @@ -0,0 +1,59 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_ocamllex +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. + +CAMLP4=../../camlp4/camlp4$(EXE) + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) + +P4INCLUDES= -nolib -I ../../etc -I ../../meta +OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -I ../../lib -I $(OCAMLTOP)/lex +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SRC=pa_ocamllex.ml +OBJS=pa_ocamllex.cmo +OBJSX=$(OBJS:.cmo=.cmx) + +all: $(OBJS) pa_ocamllex.cma + +opt: $(OBJSX) pa_ocamllex.cmxa + +pa_ocamllex.cma: pa_ocamllex.cmo + $(OCAMLC) $(OCAMLCFLAGS) cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma + +pa_ocamllex.cmxa: pa_ocamllex.cmo + $(OCAMLOPT) $(OCAMLCFLAGS) cset.cmx syntax.cmx table.cmx lexgen.cmx compact.cmx pa_ocamllex.cmx -a -o pa_ocamllex.cmxa + +clean: + rm -f *.cm* *.$(O) *.$(A) *.bak .*.bak + +depend: + +.SUFFIXES: .cmx .cmo .cmi .ml .mli + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< diff --git a/camlp4/unmaintained/ocamllex/README b/camlp4/unmaintained/ocamllex/README new file mode 100644 index 00000000..809d42f2 --- /dev/null +++ b/camlp4/unmaintained/ocamllex/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/camlp4/etc/pa_ocamllex.ml b/camlp4/unmaintained/ocamllex/pa_ocamllex.ml similarity index 89% rename from camlp4/etc/pa_ocamllex.ml rename to camlp4/unmaintained/ocamllex/pa_ocamllex.ml index f7b327de..3504d329 100644 --- a/camlp4/etc/pa_ocamllex.ml +++ b/camlp4/unmaintained/ocamllex/pa_ocamllex.ml @@ -1,6 +1,18 @@ -(* 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 *) +(* pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Alain Frisch, 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: pa_ocamllex.ml,v 1.1.2.1 2004/07/07 16:22:29 mauny Exp $ *) open Syntax open Lexgen @@ -19,7 +31,7 @@ let output_byte buf b = 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 loc = (Lexing.dummy_pos,Lexing.dummy_pos) let output_array v = let b = Buffer.create (Array.length v * 3) in @@ -256,7 +268,7 @@ EXTEND ]; definition: [ - [ x=LIDENT; pl = LIST0 Pcaml.patt; "="; + [ x=LIDENT; pl = LIST0 Pcaml.patt LEVEL "simple"; "="; short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ]; OPT "|"; l = LIST0 [ r=regexp; a=action -> (r,a) ] SEP "|" -> { name=x ; shortest=short ; args=pl ; clauses = l } ] @@ -288,7 +300,7 @@ EXTEND | "("; r = regexp; ")" -> r | "_" -> Characters all_chars | c = CHAR -> Characters (Cset.singleton (char c)) - | s = STRING -> regexp_for_string (Token.eval_string s) + | s = STRING -> regexp_for_string (Token.eval_string loc s) | "["; cc = ch_class; "]" -> Characters cc | x = LIDENT -> try Hashtbl.find named_regexps x diff --git a/camlp4/unmaintained/olabl/.depend b/camlp4/unmaintained/olabl/.depend new file mode 100644 index 00000000..e69de29b diff --git a/camlp4/unmaintained/olabl/Makefile b/camlp4/unmaintained/olabl/Makefile new file mode 100644 index 00000000..f928d458 --- /dev/null +++ b/camlp4/unmaintained/olabl/Makefile @@ -0,0 +1,61 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_lefteval +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. +CAMLP4=../../camlp4/camlp4$(EXE) + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) + +P4INCLUDES= -nolib -I ../../meta -I ../../lib -I ../../etc +OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../lib -I ../../camlp4 +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SRC=pa_olabl.ml +OBJS=$(SRC:.ml=.cmo) +OBJSX=$(SRC:.ml=.cmx) + +all: $(OBJS) + +opt: $(OBJSX) + +depend: + cp .depend .depend.bak + > .depend + for file in $(SRC); do \ + $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ + sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ + done + +clean: + rm -f *.cm* *.$(O) *.bak .*.bak + + +.SUFFIXES: .cmx .cmo .cmi .ml .mli + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +include .depend diff --git a/camlp4/unmaintained/olabl/README b/camlp4/unmaintained/olabl/README new file mode 100644 index 00000000..809d42f2 --- /dev/null +++ b/camlp4/unmaintained/olabl/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/camlp4/etc/pa_olabl.ml b/camlp4/unmaintained/olabl/pa_olabl.ml similarity index 96% rename from camlp4/etc/pa_olabl.ml rename to camlp4/unmaintained/olabl/pa_olabl.ml index ac685269..e80f69f4 100644 --- a/camlp4/etc/pa_olabl.ml +++ b/camlp4/unmaintained/olabl/pa_olabl.ml @@ -1,16 +1,19 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) (***********************************************************************) (* *) -(* Camlp4 *) +(* Camlp4 *) (* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) +(* 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: pa_olabl.ml,v 1.20 2003/07/10 12:28:20 michel Exp $ *) +(* $Id: pa_olabl.ml,v 1.1.2.1 2004/07/07 16:22:31 mauny Exp $ *) module Plexer = struct @@ -186,13 +189,18 @@ module Plexer = | [: :] -> () ] ; 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 = + value next_token_fun find_id_kwd find_spe_kwd fname lnum bolpos = + let make_pos p = + {Lexing.pos_fname = fname.val; Lexing.pos_lnum = lnum.val; + Lexing.pos_bol = bolpos.val; Lexing.pos_cnum = p} in + let mkloc (bp, ep) = (make_pos bp, make_pos ep) in + + let err loc msg = raise_with_loc loc (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) + err (mkloc (bp, ep)) ("illegal token: " ^ s) else ("", s) ] in let rec next_token = @@ -280,14 +288,14 @@ module Plexer = [ [: `'"' :] -> 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" ] + | [: :] ep -> err (mkloc (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" ] + | [: :] ep -> err (mkloc(bp,ep)) "char not terminated" ] and locate_or_antiquot bp len = parser [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) @@ -300,7 +308,7 @@ module Plexer = ("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" ] + | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] and maybe_locate bp len = parser [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) @@ -311,7 +319,7 @@ module Plexer = ("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" ] + | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] and antiquot bp len = parser [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) @@ -324,13 +332,13 @@ module Plexer = ("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" ] + | [: :] ep -> err (mkloc(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" ] + | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] and quotation bp len = parser [ [: `'>'; s :] -> maybe_end_quotation bp len s @@ -344,7 +352,7 @@ module Plexer = s :] -> quotation bp len s | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err bp ep "quotation not terminated" ] + | [: :] ep -> err (mkloc(bp,ep)) "quotation not terminated" ] and maybe_nested_quotation bp len = parser [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" @@ -366,20 +374,20 @@ module Plexer = 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)) ] + | [: tok = next_token :] ep -> (tok, mkloc(bp, ep)) + | [: _ = Stream.empty :] -> (("EOI", ""), mkloc(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)) ] + (tok, mkloc(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" ] + | [: :] ep -> err (mkloc(bp,ep)) "comment not terminated" ] and maybe_nested_comment bp = parser [ [: `'*'; s :] -> do { comment bp s; comment bp s } @@ -391,7 +399,7 @@ module Plexer = [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl; s :] -> next_token_loc s - | [: :] -> (keyword_or_error (bp, bp + 1) "#", (bp, bp + 1)) ] + | [: :] -> (keyword_or_error (bp, bp + 1) "#", mkloc(bp, bp + 1)) ] and spaces_tabs = parser [ [: `' ' | '\t'; s :] -> spaces_tabs s | [: :] -> () ] and digits = parser [ [: `'0'..'9'; s :] -> digits s | [: :] -> () ] @@ -404,7 +412,7 @@ module Plexer = fun cstrm -> try next_token_loc cstrm with [ Stream.Error str -> - err (Stream.count cstrm) (Stream.count cstrm + 1) str ] + err (mkloc(Stream.count cstrm, Stream.count cstrm + 1)) str ] ; value locerr () = invalid_arg "Lexer: location function"; value loct_create () = ref (Array.create 1024 None); @@ -429,9 +437,12 @@ module Plexer = } ; value func kwd_table = + let bolpos = ref 0 in + let lnum = ref 0 in + let fname = ref "" in let find = Hashtbl.find kwd_table in let lex cstrm = - let next_token_loc = next_token_fun find find in + let next_token_loc = next_token_fun find find fname lnum bolpos in let loct = loct_create () in let ts = Stream.from @@ -620,7 +631,7 @@ value mkumin loc f arg = <:expr< $lid:f$ $arg$ >> ] ; -external loc_of_node : 'a -> (int * int) = "%field0"; +external loc_of_node : 'a -> MLast.loc = "%field0"; value mklistexp loc last = loop True where rec loop top = @@ -1139,10 +1150,13 @@ EXTEND let x = try let i = String.index x ':' in - (int_of_string (String.sub x 0 i), + ({Lexing.pos_fname = ""; + Lexing.pos_lnum = 0; + Lexing.pos_bol = 0; + Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, String.sub x (i + 1) (String.length x - i - 1)) with - [ Not_found | Failure _ -> (0, x) ] + [ Not_found | Failure _ -> (Token.nowhere, x) ] in Pcaml.handle_expr_locate loc x | x = QUOTATION -> @@ -1265,10 +1279,13 @@ EXTEND let x = try let i = String.index x ':' in - (int_of_string (String.sub x 0 i), + ({Lexing.pos_fname = ""; + Lexing.pos_lnum = 0; + Lexing.pos_bol = 0; + Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, String.sub x (i + 1) (String.length x - i - 1)) with - [ Not_found | Failure _ -> (0, x) ] + [ Not_found | Failure _ -> (Token.nowhere, x) ] in Pcaml.handle_patt_locate loc x | x = QUOTATION -> diff --git a/camlp4/unmaintained/scheme/.depend b/camlp4/unmaintained/scheme/.depend new file mode 100644 index 00000000..e69de29b diff --git a/camlp4/unmaintained/scheme/Makefile b/camlp4/unmaintained/scheme/Makefile new file mode 100644 index 00000000..a26ed8b1 --- /dev/null +++ b/camlp4/unmaintained/scheme/Makefile @@ -0,0 +1,85 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_lefteval +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. +CAMLP4=../../camlp4/camlp4$(EXE) + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) + +P4INCLUDES= -nolib -I ../../meta -I ../../etc +OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -I ../../lib -I ../../etc +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SCHSRC=pa_scheme.sc +SRC=pa_scheme.ml pr_scheme.ml pr_schp_main.ml +OBJS=$(SRC:.ml=.cmo) +OBJSX=$(OCAMLSRC:.ml=.cmx) + +all: $(OBJS) pr_schemep.cmo camlp4sch$(EXE) + +opt: all + +bootstrap: camlp4sch$(EXE) save + ./camlp4sch$(EXE) ../../etc/q_phony.cmo ../../meta/pa_extend.cmo ../../etc/pr_r.cmo ../../etc/pr_extend.cmo ../../etc/pr_rp.cmo -impl pa_scheme.sc \ + | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' \ + -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' > pa_scheme.ml + @if cmp -s pa_scheme.ml SAVED/pa_scheme.ml; then \ + echo 'pa_scheme.ml and SAVED/pa_scheme.ml are identical' ; \ + else \ + echo '**** Note: pa_scheme.ml differs from SAVED/pa_scheme.ml'; \ + fi + +save: + test -d SAVED || mkdir SAVED + mkdir SAVED.$$$$ && mv SAVED pa_scheme.ml SAVED.$$$$ && mv SAVED.$$$$ SAVED + +restore: + mv SAVED SAVED.$$$$ && mv SAVED.$$$$/* . && rmdir SAVED.$$$$ + +depend: + cp .depend .depend.bak + > .depend + for file in $(SRC); do \ + $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ + sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ + done + +clean: + rm -f camlp4sch$(EXE) *.cm* *.$(O) *.bak .*.bak + +camlp4sch: pa_scheme.cmo + rm -f camlp4sch + DIR=`pwd` && cd ../../camlp4 && $(MAKE) CAMLP4=$$DIR/camlp4sch CAMLP4M="-I $$DIR pa_scheme.cmo ../meta/pr_dump.cmo" + +pr_schemep.cmo: pr_schp_main.cmo + $(OCAMLC) ../../etc/parserify.cmo pr_schp_main.cmo -a -o $@ + +.SUFFIXES: .cmx .cmo .cmi .ml .mli + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +include .depend diff --git a/camlp4/unmaintained/scheme/README b/camlp4/unmaintained/scheme/README new file mode 100644 index 00000000..809d42f2 --- /dev/null +++ b/camlp4/unmaintained/scheme/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/camlp4/etc/pa_schemer.ml b/camlp4/unmaintained/scheme/pa_scheme.ml similarity index 94% rename from camlp4/etc/pa_schemer.ml rename to camlp4/unmaintained/scheme/pa_scheme.ml index a7d64ce4..45b97e3c 100644 --- a/camlp4/etc/pa_schemer.ml +++ b/camlp4/unmaintained/scheme/pa_scheme.ml @@ -1,4 +1,17 @@ -(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) +(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) +(* ********************************************************************** *) +(* *) +(* Camlp4 *) +(* *) +(* 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 GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(* ********************************************************************** *) (* File generated by pretty print; do not edit! *) open Pcaml; @@ -111,7 +124,9 @@ 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") ] + raise_with_loc + (Reloc.shift_pos bp Reloc.zero_loc, Reloc.shift_pos ep Reloc.zero_loc) + (Failure "ill-formed integer constant") ] ; value base_number kwt bp len = @@ -133,7 +148,10 @@ value char_or_quote_id x = [ [: `''' :] -> ("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") + Stdpp.raise_with_loc + (Reloc.shift_pos (ep - 2) Reloc.zero_loc, + Reloc.shift_pos (ep - 1) Reloc.zero_loc) + (Stream.Error "bad quote") else let len = Buff.store (Buff.store 0 ''') x in let (s, dot) = ident len s in @@ -168,7 +186,10 @@ 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") + Stdpp.raise_with_loc + (Reloc.shift_pos (ep - 1) Reloc.zero_loc, + Reloc.shift_pos ep Reloc.zero_loc) + (Stream.Error "bad dot") | [: :] -> () ] and lexer0 kwt = parser bp @@ -262,7 +283,13 @@ value lexer_text (con, prm) = value lexer_gmake () = let kwt = Hashtbl.create 89 in - {Token.tok_func = Token.lexer_func_of_parser (lexer kwt); + {Token.tok_func = + Token.lexer_func_of_parser + (fun s -> + let (r, (bp, ep)) = lexer kwt s in + (r, + (Reloc.shift_pos bp Reloc.zero_loc, + Reloc.shift_pos ep Reloc.zero_loc))); 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} @@ -642,11 +669,10 @@ and expr_se = | Sexpr loc [se] -> let e = expr_se se in <:expr< $e$ () >> - | Sexpr loc [Slid _ "assert"; Suid _ "False" ] -> - <:expr< assert False >> + | Sexpr loc [Slid _ "assert"; Suid _ "False"] -> <:expr< assert False >> | Sexpr loc [Slid _ "assert"; se] -> let e = expr_se se in - <:expr< assert $e$ >> + <:expr< assert $e$ >> | Sexpr loc [Slid _ "lazy"; se] -> let e = expr_se se in <:expr< lazy $e$ >> diff --git a/camlp4/etc/pa_scheme.ml b/camlp4/unmaintained/scheme/pa_scheme.sc similarity index 94% rename from camlp4/etc/pa_scheme.ml rename to camlp4/unmaintained/scheme/pa_scheme.sc index 62c211de..4da7a92a 100644 --- a/camlp4/etc/pa_scheme.ml +++ b/camlp4/unmaintained/scheme/pa_scheme.sc @@ -1,5 +1,18 @@ -; 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 $ +; pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo +; ********************************************************************** +; +; Camlp4 +; +; 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 GNU Library General Public License, with +; the special exception on linking described in file +; ../../../LICENSE. +; +; ********************************************************************** +; $Id: pa_scheme.sc,v 1.1.2.1 2004/07/07 16:22:33 mauny Exp $ (open Pcaml) (open Stdpp) @@ -99,7 +112,10 @@ (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"))))) + (raise_with_loc (values + (Reloc.shift_pos bp Reloc.zero_loc) + (Reloc.shift_pos ep Reloc.zero_loc)) + (Failure "ill-formed integer constant"))))) (define (base_number kwt bp len) (parser @@ -118,7 +134,9 @@ (((` ''')) (values "CHAR" (String.make 1 x))) ((s) ep (if (List.mem x no_ident) - (Stdpp.raise_with_loc (values (- ep 2) (- ep 1)) + (Stdpp.raise_with_loc (values + (Reloc.shift_pos (- ep 2) Reloc.zero_loc) + (Reloc.shift_pos (- ep 1) Reloc.zero_loc)) (Stream.Error "bad quote")) (let* ((len (Buff.store (Buff.store 0 ''') x)) ((values s dot) (ident len s))) @@ -155,7 +173,10 @@ (no_dot (parser (((` '.')) ep - (Stdpp.raise_with_loc (values (- ep 1) ep) (Stream.Error "bad dot"))) + (Stdpp.raise_with_loc (values + (Reloc.shift_pos (- ep 1) Reloc.zero_loc) + (Reloc.shift_pos ep Reloc.zero_loc)) + (Stream.Error "bad dot"))) (() ()))) ((lexer0 kwt) (parser bp @@ -248,7 +269,12 @@ (define (lexer_gmake ()) (let ((kwt (Hashtbl.create 89))) - {(Token.tok_func (Token.lexer_func_of_parser (lexer kwt))) + {(Token.tok_func + (Token.lexer_func_of_parser + (lambda (s) + (let (((values r (values bp ep)) (lexer kwt s))) + (values r (values (Reloc.shift_pos bp Reloc.zero_loc) + (Reloc.shift_pos ep Reloc.zero_loc))))))) (Token.tok_using (lexer_using kwt)) (Token.tok_removing (lambda)) (Token.tok_match Token.default_match) @@ -605,6 +631,8 @@ ((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") (Suid _ "False")]) + <:expr< assert False >>) ((Sexpr loc [(Slid _ "assert") se]) (let ((e (expr_se se))) <:expr< assert $e$ >>)) ((Sexpr loc [(Slid _ "lazy") se]) @@ -832,7 +860,7 @@ (lambda_match ([] (assert False)) ([se] (ctyp_se se)) - ([se . sel] + ([se . sel] (let* ((t1 (ctyp_se se)) (loc (values (fst (loc_of_sexpr se)) (snd loc))) (t2 (loop sel))) diff --git a/camlp4/etc/pr_scheme.ml b/camlp4/unmaintained/scheme/pr_scheme.ml similarity index 96% rename from camlp4/etc/pr_scheme.ml rename to camlp4/unmaintained/scheme/pr_scheme.ml index 3851d454..0c938ddb 100644 --- a/camlp4/etc/pr_scheme.ml +++ b/camlp4/unmaintained/scheme/pr_scheme.ml @@ -1,5 +1,18 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(* $Id: pr_scheme.ml,v 1.1 2003/07/10 12:28:23 michel Exp $ *) +(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* 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 GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(***********************************************************************) +(* $Id: pr_scheme.ml,v 1.1.2.1 2004/07/07 16:22:33 mauny Exp $ *) open Pcaml; open Format; @@ -789,13 +802,13 @@ value apply_printer printer ast = List.fold_left (fun (first, last_pos) (si, (bp, ep)) -> do { - fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos, bp); + fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos.Lexing.pos_cnum, bp.Lexing.pos_cnum); fprintf ppf "@[%a@]@?" printer (si, nok); (False, ep) }) - (True, 0) ast + (True, Token.nowhere) ast in - fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos) + fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos.Lexing.pos_cnum) with x -> do { fprintf ppf "@."; close_in ic; raise x }; close_in ic; diff --git a/camlp4/etc/pr_schp_main.ml b/camlp4/unmaintained/scheme/pr_schp_main.ml similarity index 77% rename from camlp4/etc/pr_schp_main.ml rename to camlp4/unmaintained/scheme/pr_schp_main.ml index 30766e77..a63aca0b 100644 --- a/camlp4/etc/pr_schp_main.ml +++ b/camlp4/unmaintained/scheme/pr_schp_main.ml @@ -1,5 +1,18 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(* $Id: pr_schp_main.ml,v 1.1 2003/07/10 12:28:23 michel Exp $ *) +(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* 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 GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(***********************************************************************) +(* $Id: pr_schp_main.ml,v 1.1.2.1 2004/07/07 16:22:34 mauny Exp $ *) open Format; open Pcaml; diff --git a/camlp4/unmaintained/sml/.depend b/camlp4/unmaintained/sml/.depend new file mode 100644 index 00000000..e69de29b diff --git a/camlp4/unmaintained/sml/Makefile b/camlp4/unmaintained/sml/Makefile new file mode 100644 index 00000000..ea3980be --- /dev/null +++ b/camlp4/unmaintained/sml/Makefile @@ -0,0 +1,68 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_sml +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) -nostdlib -I $(OCAMLTOP)/stdlib +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) -nostdlib -I $(OCAMLTOP)/stdlib + +P4INCLUDES=-I ../../meta -I ../../etc -I ../../lib -I ../../camlp4 +OCAMLINCLUDES=-I ../../meta -I ../../lib -I ../../camlp4 + +CAMLP4=camlp4$(EXE) -nolib +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SRC=pa_sml.ml +OBJS=$(SRC:.ml=.cmo) +OBJSX=$(SRC:.ml=.cmx) + +all: $(OBJS) smllib.cmo + +opt: $(OBJSX) smllib.cmx + +depend: + cp .depend .depend.bak + > .depend + for file in $(SRC); do \ + $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ + sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ + done + +clean: + rm -f *.cm* *.o *.bak .*.bak + + +.SUFFIXES: .cmx .cmo .cmi .ml .mli .sml + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.sml.cmo: + $(OCAMLC) -I ../../../otherlibs/unix -pp "$(CAMLP4) ./pa_sml.cmo ../../meta/pr_dump.cmo -impl" -c -o $*.cmo -impl $< + +.sml.cmx: + $(OCAMLOPT) -I ../../../otherlibs/unix -pp "$(CAMLP4) ./pa_sml.cmo ../../meta/pr_dump.cmo -impl" -c -o $*.cmx -impl $< + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +include .depend diff --git a/camlp4/unmaintained/sml/README b/camlp4/unmaintained/sml/README new file mode 100644 index 00000000..809d42f2 --- /dev/null +++ b/camlp4/unmaintained/sml/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/camlp4/etc/pa_sml.ml b/camlp4/unmaintained/sml/pa_sml.ml similarity index 97% rename from camlp4/etc/pa_sml.ml rename to camlp4/unmaintained/sml/pa_sml.ml index 287d76ab..8ea5c4b8 100644 --- a/camlp4/etc/pa_sml.ml +++ b/camlp4/unmaintained/sml/pa_sml.ml @@ -1,16 +1,19 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) (***********************************************************************) (* *) -(* Camlp4 *) +(* Camlp4 *) (* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) +(* en Automatique. All 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: pa_sml.ml,v 1.10 2003/07/10 12:28:21 michel Exp $ *) +(* $Id: pa_sml.ml,v 1.1.2.1 2004/07/07 16:37:10 mauny Exp $ *) open Stdpp; open Pcaml; @@ -912,7 +915,9 @@ EXTEND else match x4 with [ <:module_expr< struct $list:list$ end >> -> - let si = let loc = (0, 0) in <:str_item< open AAA >> in + let si = + let loc = (Token.nowhere, Token.nowhere) in + <:str_item< open AAA >> in <:module_expr< struct $list:[si :: list]$ end >> | _ -> not_impl loc "fctb 1" ] in diff --git a/camlp4/etc/lib.sml b/camlp4/unmaintained/sml/smllib.sml similarity index 91% rename from camlp4/etc/lib.sml rename to camlp4/unmaintained/sml/smllib.sml index 5c8555bb..bf9baf15 100644 --- a/camlp4/etc/lib.sml +++ b/camlp4/unmaintained/sml/smllib.sml @@ -1,4 +1,15 @@ -(* $Id: lib.sml,v 1.2 2002/07/19 14:53:45 mauny Exp $ *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: smllib.sml,v 1.1.2.1 2004/07/07 16:37:11 mauny Exp $ *) datatype 'a option = SOME of 'a | NONE exception Fail of string @@ -119,7 +130,7 @@ structure TextIO = val openOut = open_out fun closeIn (ic, ahc) = (ahc := SOME NONE; close_in ic) val closeOut = close_out - val stdIn = (stdin, ref NONE) + val stdIn = (stdin, ref (NONE : char option option)) fun endOfStream (ic, _) = pos_in ic = in_channel_length ic fun inputLine (ic, ahc) = case !ahc of @@ -375,7 +386,7 @@ 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") +val use_hook = ref (fn (s : string) => (failwith "no defined directive use" : unit)) fun use s = !use_hook s fun isSome (SOME _) = true | isSome NONE = false diff --git a/config/Makefile-templ b/config/Makefile-templ index f11b3a01..359b8dd2 100644 --- a/config/Makefile-templ +++ b/config/Makefile-templ @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile-templ,v 1.27 2003/07/03 15:13:22 xleroy Exp $ +# $Id: Makefile-templ,v 1.29 2004/06/19 16:17:31 xleroy Exp $ ### Compile-time configuration @@ -111,8 +111,8 @@ SHARPBANGSCRIPTS=true ### 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 +### hppa HP 9000/700 under HPUX and Linux +### power Macintosh under Mac OS X and Linux ### ia64 Intel Itanium/IA64 under Linux ### arm ARM under Linux ### @@ -133,18 +133,9 @@ SHARPBANGSCRIPTS=true ### 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. -### +### If ARCH=power: set MODEL=ppc ### For other architectures: leave MODEL=default ### -#MODEL=rs6000 #MODEL=ppc #MODEL=default @@ -261,12 +252,17 @@ 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 +# generic (portable C, works everywhere) +# ia32 (Intel x86) +# amd64 (AMD Opteron, Athlon64) +# alpha +# mips +# ppc (Power PC) +# sparc +# If you don't know, leave BNG_ARCH=generic, which selects a portable # C implementation of these routines. -BIGNUM_ARCH=alpha +BNG_ARCH=generic +BNG_ASM_LEVEL=1 ### Link-time options to ocamlc or ocamlopt for linking with POSIX threads # Needed for the "systhreads" package diff --git a/config/Makefile.mingw b/config/Makefile.mingw index 6360e652..e9267140 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.mingw,v 1.11 2003/07/08 15:12:58 xleroy Exp $ +# $Id: Makefile.mingw,v 1.12 2004/04/01 13:08:56 xleroy Exp $ # Configuration for Windows, Mingw compiler @@ -108,7 +108,8 @@ BINUTILS_OBJCOPY=objcopy OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk ### Name of the target architecture for the "num" library -BIGNUM_ARCH=C +BNG_ARCH=ia32 +BNG_ASM_LEVEL=1 ### Configuration for LablTk # Set TK_ROOT to the directory where you installed TCL/TK 8.3 diff --git a/config/Makefile.msvc b/config/Makefile.msvc index 9b995b42..29d8d3d3 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.msvc,v 1.11 2003/07/03 16:14:49 xleroy Exp $ +# $Id: Makefile.msvc,v 1.12 2004/04/01 13:08:56 xleroy Exp $ # Configuration for Windows, Visual C++ compiler @@ -108,7 +108,8 @@ BINUTILS_OBJCOPY=objcopy OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk ### Name of the target architecture for the "num" library -BIGNUM_ARCH=C +BNG_ARCH=generic +BNG_ASM_LEVEL=0 ### Configuration for LablTk # Set TK_ROOT to the directory where you installed TCL/TK 8.3 diff --git a/config/auto-aux/divmod.c b/config/auto-aux/divmod.c index 24d3786c..fb579c5e 100644 --- a/config/auto-aux/divmod.c +++ b/config/auto-aux/divmod.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id$ */ +/* $Id: divmod.c,v 1.3 2003/12/30 23:59:47 doligez Exp $ */ /* Test semantics of division and modulus for negative arguments */ diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot index 99384768..5014b903 100755 --- a/config/auto-aux/hasgot +++ b/config/auto-aux/hasgot @@ -4,10 +4,11 @@ opts="" libs="$cclibs" args=$* rm -f hasgot.c +var="x" while : ; do case "$1" in -i) echo "#include <$2>" >> hasgot.c; shift;; - -t) echo "$2 the_$2;" >> hasgot.c; shift;; + -t) echo "$2 $var;" >> hasgot.c; var="x$var"; shift;; -l*|-L*|-F*) libs="$libs $1";; -framework) libs="$libs $1 $2"; shift;; -*) opts="$opts $1";; diff --git a/config/s-MacOS.h b/config/auto-aux/ia32sse2.c similarity index 64% rename from config/s-MacOS.h rename to config/auto-aux/ia32sse2.c index b804bb73..fc2b4e43 100644 --- a/config/s-MacOS.h +++ b/config/auto-aux/ia32sse2.c @@ -2,19 +2,21 @@ /* */ /* Objective Caml */ /* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ -/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* 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. */ +/* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ -/* $Id: s-MacOS.h,v 1.4 2001/12/07 13:39:40 xleroy Exp $ */ +/* $Id: ia32sse2.c,v 1.1 2003/10/24 09:18:01 xleroy Exp $ */ -#define OCAML_OS_TYPE "MacOS" -#define HAS_STRERROR -#define HAS_GETCWD +/* Test whether IA32 assembler supports SSE2 instructions */ -#define HAS_UI +int main() +{ + asm("pmuludq %mm1, %mm0"); + return 0; +} diff --git a/config/config.Mac b/config/config.Mac deleted file mode 100644 index 5de19fd1..00000000 --- a/config/config.Mac +++ /dev/null @@ -1,76 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, Projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../LICENSE. # -# # -######################################################################### - -# $Id: 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 index 7620ff94..d25d58fe 100755 --- a/config/gnu/config.guess +++ b/config/gnu/config.guess @@ -1,9 +1,9 @@ #! /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. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002, 2003 Free Software Foundation, Inc. -timestamp='2001-06-25' +timestamp='2004-02-16' # 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 @@ -24,8 +24,9 @@ timestamp='2001-06-25' # 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 . +# Originally written by Per Bothner . +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. # # This script attempts to guess a canonical system name similar to # config.sub. If it succeeds, it prints the system name on stdout, and @@ -87,33 +88,45 @@ if test $# != 0; then exit 1 fi +trap 'exit 1' 1 2 15 -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. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. -# 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. +# Portable tmp directory creation inspired by the Autoconf team. + +set_cc_for_build=' +trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; +trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; +: ${TMPDIR=/tmp} ; + { tmp=`(umask 077 && mktemp -d -q "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || + { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || + { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; +dummy=$tmp/dummy ; +tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; 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 + ,,) echo "int x;" > $dummy.c ; + for c in cc gcc c89 c99 ; do + if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; if test x"$CC_FOR_BUILD" = x ; then - CC_FOR_BUILD=no_compiler_found + CC_FOR_BUILD=no_compiler_found ; fi ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; -esac +esac ;' # This is needed to find uname on a Pyramid OSx when run in the BSD universe. -# (ghazi@noc.rutgers.edu 8/24/94.) +# (ghazi@noc.rutgers.edu 1994-08-24) if (test -f /.attbin/uname) >/dev/null 2>&1 ; then PATH=$PATH:/.attbin ; export PATH fi @@ -127,29 +140,31 @@ UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in *:NetBSD:*:*) - # Netbsd (nbsd) targets should (where applicable) match one or + # 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 ;; + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + *) machine=${UNAME_MACHINE_ARCH}-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) + case "${UNAME_MACHINE_ARCH}" in + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep __ELF__ >/dev/null then @@ -165,71 +180,130 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in ;; esac # The OS release - release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + # Debian GNU/NetBSD machines have a different userland, and + # thus, need a distinct triplet. However, they do not need + # kernel version information, so it can be replaced with a + # suitable tag, in the style of linux-gnu. + case "${UNAME_VERSION}" in + Debian*) + release='-gnu' + ;; + *) + release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + ;; + esac # 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 ;; + amd64:OpenBSD:*:*) + echo x86_64-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + amiga:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + arc:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + cats:OpenBSD:*:*) + echo arm-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + hp300:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mac68k:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + macppc:OpenBSD:*:*) + echo powerpc-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 ;; + mvmeppc:OpenBSD:*:*) + echo powerpc-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + pegasos:OpenBSD:*:*) + echo powerpc-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + pmax:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + sgi:OpenBSD:*:*) + echo mipseb-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + sun3:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + wgrisc:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + *:OpenBSD:*:*) + echo ${UNAME_MACHINE}-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + *:ekkoBSD:*:*) + echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} + exit 0 ;; + macppc:MirBSD:*:*) + echo powerppc-unknown-mirbsd${UNAME_RELEASE} + exit 0 ;; + *:MirBSD:*:*) + echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} + exit 0 ;; alpha:OSF1:*:*) if test $UNAME_RELEASE = "V4.0"; then UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` fi + # According to Compaq, /usr/sbin/psrinfo has been available on + # OSF/1 and Tru64 systems produced since 1995. I hope that + # covers most systems running today. This code pipes the CPU + # types through head -n 1, so we only detect the type of CPU 0. + ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` + case "$ALPHA_CPU_TYPE" in + "EV4 (21064)") + UNAME_MACHINE="alpha" ;; + "EV4.5 (21064)") + UNAME_MACHINE="alpha" ;; + "LCA4 (21066/21068)") + UNAME_MACHINE="alpha" ;; + "EV5 (21164)") + UNAME_MACHINE="alphaev5" ;; + "EV5.6 (21164A)") + UNAME_MACHINE="alphaev56" ;; + "EV5.6 (21164PC)") + UNAME_MACHINE="alphapca56" ;; + "EV5.7 (21164PC)") + UNAME_MACHINE="alphapca57" ;; + "EV6 (21264)") + UNAME_MACHINE="alphaev6" ;; + "EV6.7 (21264A)") + UNAME_MACHINE="alphaev67" ;; + "EV6.8CB (21264C)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8AL (21264B)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8CX (21264D)") + UNAME_MACHINE="alphaev68" ;; + "EV6.9A (21264/EV69A)") + UNAME_MACHINE="alphaev69" ;; + "EV7 (21364)") + UNAME_MACHINE="alphaev7" ;; + "EV7.9 (21364A)") + UNAME_MACHINE="alphaev79" ;; + esac # 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*:OpenVMS:*:*) + echo alpha-hp-vms + 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 @@ -242,33 +316,18 @@ EOF 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} + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos exit 0 ;; *:OS/390:*:*) echo i370-ibm-openedition exit 0 ;; + *:OS400:*:*) + echo powerpc-ibm-os400 + exit 0 ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) echo arm-acorn-riscix${UNAME_RELEASE} exit 0;; @@ -286,6 +345,13 @@ EOF NILE*:*:*:dcosx) echo pyramid-pyramid-svr4 exit 0 ;; + DRS?6000:unix:4.0:6*) + echo sparc-icl-nx6 + exit 0 ;; + DRS?6000:UNIX_SV:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) echo sparc-icl-nx7 && exit 0 ;; + esac ;; sun4H:SunOS:5.*:*) echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit 0 ;; @@ -314,7 +380,7 @@ EOF 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` + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) @@ -328,9 +394,6 @@ EOF 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 @@ -357,17 +420,8 @@ EOF *:*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} + m68k:machten:*:*) + echo m68k-apple-machten${UNAME_RELEASE} exit 0 ;; powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} @@ -385,6 +439,7 @@ EOF echo clipper-intergraph-clix${UNAME_RELEASE} exit 0 ;; mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __cplusplus #include /* for printf() prototype */ @@ -406,15 +461,20 @@ EOF 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 + $CC_FOR_BUILD -o $dummy $dummy.c \ + && $dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \ + && exit 0 echo mips-mips-riscos${UNAME_RELEASE} exit 0 ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax exit 0 ;; + Motorola:*:4.3:PL8-*) + echo powerpc-harris-powermax + exit 0 ;; + Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) + echo powerpc-harris-powermax + exit 0 ;; Night_Hawk:Power_UNIX:*:*) echo powerpc-harris-powerunix exit 0 ;; @@ -475,6 +535,7 @@ EOF exit 0 ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include @@ -486,8 +547,7 @@ EOF exit(0); } EOF - $CC_FOR_BUILD $dummy.c -o $dummy && ./$dummy && rm -f $dummy.c $dummy && exit 0 - rm -f $dummy.c $dummy + $CC_FOR_BUILD -o $dummy $dummy.c && $dummy && exit 0 echo rs6000-ibm-aix3.2.5 elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then echo rs6000-ibm-aix3.2.4 @@ -496,7 +556,7 @@ EOF fi exit 0 ;; *:AIX:*:[45]) - IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | head -1 | awk '{ print $1 }'` + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else @@ -536,10 +596,8 @@ EOF 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` + 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 @@ -548,12 +606,13 @@ EOF case "${sc_kernel_bits}" in 32) HP_ARCH="hppa2.0n" ;; 64) HP_ARCH="hppa2.0w" ;; + '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 esac ;; esac - fi ;; - esac - if [ "${HP_ARCH}" = "" ]; then - sed 's/^ //' << EOF >$dummy.c + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c #define _HPUX_SOURCE #include @@ -586,11 +645,21 @@ EOF 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 ;; + (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` + test -z "$HP_ARCH" && HP_ARCH=hppa + fi ;; esac + if [ ${HP_ARCH} = "hppa2.0w" ] + then + # avoid double evaluation of $set_cc_for_build + test -n "$CC_FOR_BUILD" || eval $set_cc_for_build + if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E -) | grep __LP64__ >/dev/null + then + HP_ARCH="hppa2.0w" + else + HP_ARCH="hppa64" + fi + fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} exit 0 ;; ia64:HP-UX:*:*) @@ -598,6 +667,7 @@ EOF echo ia64-hp-hpux${HPUX_REV} exit 0 ;; 3050*:HI-UX:*:*) + eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include int @@ -623,8 +693,7 @@ EOF exit (0); } EOF - $CC_FOR_BUILD $dummy.c -o $dummy && ./$dummy && rm -f $dummy.c $dummy && exit 0 - rm -f $dummy.c $dummy + $CC_FOR_BUILD -o $dummy $dummy.c && $dummy && exit 0 echo unknown-hitachi-hiuxwe2 exit 0 ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) @@ -633,7 +702,7 @@ EOF 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd exit 0 ;; - *9??*:MPE/iX:*:*) + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix exit 0 ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) @@ -652,9 +721,6 @@ EOF 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 ;; @@ -673,40 +739,37 @@ EOF 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} + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' 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/ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' 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 ;; + *:UNICOS/mp:*:*) + echo nv1-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + 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} + 5000:UNIX_System_V:4.*:*) + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` + echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit 0 ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} @@ -718,10 +781,21 @@ EOF 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/[-_].*/\./'` + # Determine whether the default compiler uses glibc. + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + #if __GLIBC__ >= 2 + LIBC=gnu + #else + LIBC= + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` + # GNU/KFreeBSD systems have a "k" prefix to indicate we are using + # FreeBSD's kernel, but not the complete OS. + case ${LIBC} in gnu) kernel_only='k' ;; esac + echo ${UNAME_MACHINE}-unknown-${kernel_only}freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`${LIBC:+-$LIBC} exit 0 ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin @@ -732,11 +806,17 @@ EOF i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 exit 0 ;; + x86:Interix*:[34]*) + echo i586-pc-interix${UNAME_RELEASE}|sed -e 's/\..*//' + exit 0 ;; + [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) + echo i${UNAME_MACHINE}-pc-mks + 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 + echo i586-pc-interix exit 0 ;; i*:UWIN*:*) echo ${UNAME_MACHINE}-pc-uwin @@ -748,8 +828,13 @@ EOF echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit 0 ;; *:GNU:*:*) + # the GNU system echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit 0 ;; + *:GNU/*:*:*) + # other systems with GNU libc and userland + echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu + exit 0 ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix exit 0 ;; @@ -759,104 +844,71 @@ EOF sa110:Linux:*:*) echo arm-unknown-linux-gnu exit 0 ;; + cris:Linux:*:*) + echo cris-axis-linux-gnu + exit 0 ;; ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux + echo ${UNAME_MACHINE}-unknown-linux-gnu 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; -} + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef mips + #undef mipsel + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=mipsel + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=mips + #else + CPU= + #endif + #endif 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 + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` + test x"${CPU}" != x && echo "${CPU}-unknown-linux-gnu" && exit 0 ;; - 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; -} + mips64:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef mips64 + #undef mips64el + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=mips64el + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=mips64 + #else + CPU= + #endif + #endif 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} + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` + test x"${CPU}" != x && echo "${CPU}-unknown-linux-gnu" && exit 0 + ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-gnu + exit 0 ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-gnu 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 + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null + if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} exit 0 ;; parisc:Linux:*:* | hppa:Linux:*:*) @@ -873,6 +925,9 @@ EOF s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux exit 0 ;; + sh64*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit 0 ;; sh*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit 0 ;; @@ -886,7 +941,8 @@ EOF # 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 \ + # Set LC_ALL=C to ensure ld outputs messages in English. + ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ | sed -ne '/supported targets:/!d s/[ ][ ]*/ /g s/.*supported targets: *// @@ -898,7 +954,7 @@ EOF ;; a.out-i386-linux) echo "${UNAME_MACHINE}-pc-linux-gnuaout" - exit 0 ;; + exit 0 ;; coff-i386) echo "${UNAME_MACHINE}-pc-linux-gnucoff" exit 0 ;; @@ -909,37 +965,38 @@ EOF 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; -} + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + #ifdef __ELF__ + # ifdef __GLIBC__ + # if __GLIBC__ >= 2 + LIBC=gnu + # else + LIBC=gnulibc1 + # endif + # else + LIBC=gnulibc1 + # endif + #else + #ifdef __INTEL_COMPILER + LIBC=gnu + #else + LIBC=gnuaout + #endif + #endif + #ifdef __dietlibc__ + LIBC=dietlibc + #endif 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 + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` + test x"${LIBC}" != x && echo "${UNAME_MACHINE}-pc-linux-${LIBC}" && exit 0 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*:*) + # 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. echo i386-sequent-sysv4 exit 0 ;; i*86:UNIX_SV:4.2MP:2.*) @@ -950,6 +1007,26 @@ EOF # Use sysv4.2uw... so that sysv4* matches it. echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} 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 ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit 0 ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit 0 ;; + i*86:syllable:*:*) + echo ${UNAME_MACHINE}-pc-syllable + exit 0 ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + 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 @@ -961,7 +1038,7 @@ EOF i*86:*:5:[78]*) case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; - *Pentium*) UNAME_MACHINE=i586 ;; + *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} @@ -971,22 +1048,19 @@ EOF 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_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ && UNAME_MACHINE=i586 - (/bin/uname -X|egrep '^Machine.*Pent ?II' >/dev/null) \ + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ && UNAME_MACHINE=i686 - (/bin/uname -X|egrep '^Machine.*Pentium Pro' >/dev/null) \ + (/bin/uname -X|grep '^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 @@ -1010,9 +1084,15 @@ EOF # "miniframe" echo m68010-convergent-sysv exit 0 ;; + mc68k:UNIX:SYSTEM5:3.51m) + echo m68k-convergent-sysv + exit 0 ;; + M680?0:D-NIX:5.3:*) + echo m68k-diab-dnix + 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) + 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` @@ -1029,9 +1109,6 @@ EOF 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 ;; @@ -1058,8 +1135,8 @@ EOF echo ns32k-sni-sysv fi exit 0 ;; - PENTIUM:CPunix:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort - # says + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says echo i586-unisys-sysv4 exit 0 ;; *:UNIX_System_V:4*:FTX*) @@ -1071,6 +1148,10 @@ EOF # From seanf@swdc.stratus.com. echo i860-stratus-sysv4 exit 0 ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit 0 ;; mc68*:A/UX:*:*) echo m68k-apple-aux${UNAME_RELEASE} exit 0 ;; @@ -1102,6 +1183,9 @@ EOF osfmach3_ppc:*:*:*) echo powerpc-unknown-linux exit 0 ;; + SX-6:SUPER-UX:*:*) + echo sx6-nec-superux${UNAME_RELEASE} + exit 0 ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit 0 ;; @@ -1109,18 +1193,24 @@ EOF echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} exit 0 ;; *:Darwin:*:*) - echo `uname -p`-apple-darwin${UNAME_RELEASE} + case `uname -p` in + *86) UNAME_PROCESSOR=i686 ;; + powerpc) UNAME_PROCESSOR=powerpc ;; + esac + echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit 0 ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) - if test "${UNAME_MACHINE}" = "x86pc"; then + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = "x86"; then + UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi - echo `uname -p`-${UNAME_MACHINE}-nto-qnx + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} exit 0 ;; *:QNX:*:4*) echo i386-pc-qnx exit 0 ;; - NSR-[KW]:NONSTOP_KERNEL:*:*) + NSR-?:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} exit 0 ;; *:NonStop-UX:*:*) @@ -1143,11 +1233,6 @@ EOF 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 ;; @@ -1166,11 +1251,18 @@ EOF *:ITS:*:*) echo pdp10-unknown-its exit 0 ;; + SEI:*:*:SEIUX) + echo mips-sei-seiux${UNAME_RELEASE} + exit 0 ;; + *:DragonFly:*:*) + echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + 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 +eval $set_cc_for_build cat >$dummy.c < @@ -1286,8 +1378,7 @@ main () } EOF -$CC_FOR_BUILD $dummy.c -o $dummy 2>/dev/null && ./$dummy && rm -f $dummy.c $dummy && exit 0 -rm -f $dummy.c $dummy +$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && $dummy && exit 0 # Apollos put the system type in the environment. diff --git a/config/gnu/config.sub b/config/gnu/config.sub index fdcc42bc..d2e3557a 100755 --- a/config/gnu/config.sub +++ b/config/gnu/config.sub @@ -1,9 +1,9 @@ #! /bin/sh # Configuration validation subroutine script. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 -# Free Software Foundation, Inc. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002, 2003 Free Software Foundation, Inc. -timestamp='2001-06-08' +timestamp='2004-02-16' # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software @@ -29,7 +29,8 @@ timestamp='2001-06-08' # 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 . +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. @@ -117,7 +118,8 @@ esac # 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-*) + nto-qnx* | linux-gnu* | linux-dietlibc | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | \ + kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; @@ -223,26 +225,50 @@ esac 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) + 1750a | 580 \ + | a29k \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | am33_2.0 \ + | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ + | c4x | clipper \ + | d10v | d30v | dlx | dsp16xx \ + | fr30 | frv \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | i370 | i860 | i960 | ia64 \ + | ip2k | iq2000 \ + | m32r | m68000 | m68k | m88k | mcore \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64vr | mips64vrel \ + | mips64orion | mips64orionel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mipsisa32 | mipsisa32el \ + | mipsisa32r2 | mipsisa32r2el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64r2 | mipsisa64r2el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipsisa64sr71k | mipsisa64sr71kel \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | msp430 \ + | ns16k | ns32k \ + | openrisc | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ + | pyramid \ + | sh | sh[1234] | sh[23]e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv9 | sparcv9b \ + | strongarm \ + | tahoe | thumb | tic4x | tic80 | tron \ + | v850 | v850e \ + | we32k \ + | x86 | xscale | xstormy16 | xtensa \ + | z8k) basic_machine=$basic_machine-unknown ;; m6811 | m68hc11 | m6812 | m68hc12) @@ -265,31 +291,61 @@ case $basic_machine in 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-*) + 580-* \ + | a29k-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ + | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ + | avr-* \ + | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \ + | clipper-* | cydra-* \ + | d10v-* | d30v-* | dlx-* \ + | elxsi-* \ + | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | i*86-* | i860-* | i960-* | ia64-* \ + | ip2k-* | iq2000-* \ + | m32r-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | mcore-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64vr-* | mips64vrel-* \ + | mips64orion-* | mips64orionel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa32r2-* | mipsisa32r2el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64r2-* | mipsisa64r2el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipsisa64sr71k-* | mipsisa64sr71kel-* \ + | mipstx39-* | mipstx39el-* \ + | msp430-* \ + | none-* | np1-* | nv1-* | ns16k-* | ns32k-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ + | pyramid-* \ + | romp-* | rs6000-* \ + | sh-* | sh[1234]-* | sh[23]e-* | sh[34]eb-* | shbe-* \ + | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \ + | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \ + | tahoe-* | thumb-* \ + | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ + | tron-* \ + | v850-* | v850e-* | vax-* \ + | we32k-* \ + | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \ + | xtensa-* \ + | ymp-* \ + | z8k-*) ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. @@ -307,6 +363,9 @@ case $basic_machine in basic_machine=a29k-amd os=-udi ;; + abacus) + basic_machine=abacus-unknown + ;; adobe68k) basic_machine=m68010-adobe os=-scout @@ -321,6 +380,12 @@ case $basic_machine in basic_machine=a29k-none os=-bsd ;; + amd64) + basic_machine=x86_64-pc + ;; + amd64-*) + basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; amdahl) basic_machine=580-amdahl os=-sysv @@ -352,6 +417,10 @@ case $basic_machine in basic_machine=ns32k-sequent os=-dynix ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; convex-c1) basic_machine=c1-convex os=-bsd @@ -372,17 +441,13 @@ case $basic_machine in basic_machine=c38-convex os=-bsd ;; - cray | ymp) - basic_machine=ymp-cray - os=-unicos - ;; - cray2) - basic_machine=cray2-cray + cray | j90) + basic_machine=j90-cray os=-unicos ;; - [cjt]90) - basic_machine=${basic_machine}-cray - os=-unicos + cr16c) + basic_machine=cr16c-unknown + os=-elf ;; crds | unos) basic_machine=m68k-crds @@ -396,6 +461,14 @@ case $basic_machine in decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) basic_machine=mips-dec ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) basic_machine=m68k-motorola @@ -576,14 +649,6 @@ case $basic_machine in 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/'` ;; @@ -598,6 +663,10 @@ case $basic_machine in basic_machine=m68k-rom68k os=-coff ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; msdos) basic_machine=i386-pc os=-msdos @@ -670,6 +739,10 @@ case $basic_machine in np1) basic_machine=np1-gould ;; + nv1) + basic_machine=nv1-cray + os=-unicosmp + ;; nsr-tandem) basic_machine=nsr-tandem ;; @@ -677,6 +750,14 @@ case $basic_machine in basic_machine=hppa1.1-oki os=-proelf ;; + or32 | or32-*) + basic_machine=or32-unknown + os=-coff + ;; + os400) + basic_machine=powerpc-ibm + os=-os400 + ;; OSE68000 | ose68000) basic_machine=m68000-ericsson os=-ose @@ -699,42 +780,58 @@ case $basic_machine in pbb) basic_machine=m68k-tti ;; - pc532 | pc532-*) + pc532 | pc532-*) basic_machine=ns32k-pc532 ;; - pentium | p5 | k5 | k6 | nexgen) + pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; - pentiumpro | p6 | 6x86 | athlon) + pentiumpro | p6 | 6x86 | athlon | athlon_*) basic_machine=i686-pc ;; - pentiumii | pentium2) + pentiumii | pentium2 | pentiumiii | pentium3) basic_machine=i686-pc ;; - pentium-* | p5-* | k5-* | k6-* | nexgen-*) + pentium4) + basic_machine=i786-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumpro-* | p6-* | 6x86-* | athlon-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; - pentiumii-* | pentium2-*) + pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; + pentium4-*) + basic_machine=i786-`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/^[^-]*-//'` ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little | ppc64-le | powerpc64-little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; ps2) basic_machine=i386-ibm ;; @@ -752,10 +849,26 @@ case $basic_machine in rtpc | rtpc-*) basic_machine=romp-ibm ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; sa29200) basic_machine=a29k-amd os=-udi ;; + sb1) + basic_machine=mipsisa64sb1-unknown + ;; + sb1el) + basic_machine=mipsisa64sb1el-unknown + ;; + sei) + basic_machine=mips-sei + os=-seiux + ;; sequent) basic_machine=i386-sequent ;; @@ -763,7 +876,10 @@ case $basic_machine in basic_machine=sh-hitachi os=-hms ;; - sparclite-wrs) + sh64) + basic_machine=sh64-unknown + ;; + sparclite-wrs | simso-wrs) basic_machine=sparclite-wrs os=-vxworks ;; @@ -830,22 +946,42 @@ case $basic_machine in os=-dynix ;; t3e) - basic_machine=t3e-cray + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray os=-unicos ;; tic54x | c54x*) basic_machine=tic54x-unknown os=-coff ;; + tic55x | c55x*) + basic_machine=tic55x-unknown + os=-coff + ;; + tic6x | c6x*) + basic_machine=tic6x-unknown + os=-coff + ;; tx39) basic_machine=mipstx39-unknown ;; tx39el) basic_machine=mipstx39el-unknown ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; tower | tower-32) basic_machine=m68k-ncr ;; + tpf) + basic_machine=s390x-ibm + os=-tpf + ;; udi29k) basic_machine=a29k-amd os=-udi @@ -867,8 +1003,8 @@ case $basic_machine in os=-vms ;; vpp*|vx|vx-*) - basic_machine=f301-fujitsu - ;; + basic_machine=f301-fujitsu + ;; vxworks960) basic_machine=i960-wrs os=-vxworks @@ -889,17 +1025,13 @@ case $basic_machine in basic_machine=hppa1.1-winbond os=-proelf ;; - windows32) - basic_machine=i386-pc - os=-windows32-msvcrt + xps | xps100) + basic_machine=xps100-honeywell ;; - xmp) - basic_machine=xmp-cray + ymp) + basic_machine=ymp-cray os=-unicos ;; - xps | xps100) - basic_machine=xps100-honeywell - ;; z8k-*-coff) basic_machine=z8k-unknown os=-sim @@ -920,13 +1052,6 @@ case $basic_machine in 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 ;; @@ -946,13 +1071,16 @@ case $basic_machine in we32k) basic_machine=we32k-att ;; - sh3 | sh4) + sh3 | sh4 | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; + sh64) + basic_machine=sh64-unknown + ;; sparc | sparcv9 | sparcv9b) basic_machine=sparc-sun ;; - cydra) + cydra) basic_machine=cydra-cydrome ;; orion) @@ -967,10 +1095,6 @@ case $basic_machine in pmac | pmac-mpw) basic_machine=powerpc-apple ;; - c4x*) - basic_machine=c4x-none - os=-coff - ;; *-unknown) # Make sure to match an already-canonicalized machine name. ;; @@ -1026,16 +1150,20 @@ case $os in | -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* \ + | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* | -openbsd* \ + | -ekkobsd* | -kfreebsd* | -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* \ + | -mingw32* | -linux-gnu* | -linux-uclibc* | -uxpv* | -beos* | -mpeix* | -udk* \ + | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ - | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* | -os2*) + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ + | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) @@ -1047,8 +1175,10 @@ case $os in ;; esac ;; + -nto-qnx*) + ;; -nto*) - os=-nto-qnx + os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ @@ -1057,6 +1187,9 @@ case $os in -mac*) os=`echo $os | sed -e 's|mac|macos|'` ;; + -linux-dietlibc) + os=-linux-dietlibc + ;; -linux*) os=`echo $os | sed -e 's|linux|linux-gnu|'` ;; @@ -1069,6 +1202,9 @@ case $os in -opened*) os=-openedition ;; + -os400*) + os=-os400 + ;; -wince*) os=-wince ;; @@ -1087,14 +1223,23 @@ case $os in -acis*) os=-aos ;; + -atheos*) + os=-atheos + ;; + -syllable*) + os=-syllable + ;; -386bsd) os=-bsd ;; -ctix* | -uts*) os=-sysv ;; + -nova*) + os=-rtmk-nova + ;; -ns2 ) - os=-nextstep2 + os=-nextstep2 ;; -nsk*) os=-nsk @@ -1106,6 +1251,9 @@ case $os in -sinix*) os=-sysv4 ;; + -tpf*) + os=-tpf + ;; -triton*) os=-sysv3 ;; @@ -1133,8 +1281,14 @@ case $os in -xenix) os=-xenix ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - os=-mint + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -aros*) + os=-aros + ;; + -kaos*) + os=-kaos ;; -none) ;; @@ -1167,10 +1321,14 @@ case $basic_machine in arm*-semi) os=-aout ;; + c4x-* | tic4x-*) + os=-coff + ;; + # This must come before the *-dec entry. pdp10-*) os=-tops20 ;; - pdp11-*) + pdp11-*) os=-none ;; *-dec | vax-*) @@ -1197,6 +1355,9 @@ case $basic_machine in mips*-*) os=-elf ;; + or32-*) + os=-coff + ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; @@ -1260,19 +1421,19 @@ case $basic_machine in *-next) os=-nextstep3 ;; - *-gould) + *-gould) os=-sysv ;; - *-highlevel) + *-highlevel) os=-bsd ;; *-encore) os=-bsd ;; - *-sgi) + *-sgi) os=-irix ;; - *-siemens) + *-siemens) os=-sysv4 ;; *-masscomp) @@ -1341,10 +1502,16 @@ case $basic_machine in -mvs* | -opened*) vendor=ibm ;; + -os400*) + vendor=ibm + ;; -ptx*) vendor=sequent ;; - -vxsim* | -vxworks*) + -tpf*) + vendor=ibm + ;; + -vxsim* | -vxworks* | -windiss*) vendor=wrs ;; -aux*) @@ -1359,6 +1526,9 @@ case $basic_machine in -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) vendor=atari ;; + -vos*) + vendor=stratus + ;; esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; diff --git a/config/m-MacOS.h b/config/m-MacOS.h deleted file mode 100644 index 1925449b..00000000 --- a/config/m-MacOS.h +++ /dev/null @@ -1,33 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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/s-templ.h b/config/s-templ.h index 80857c24..edc3860e 100644 --- a/config/s-templ.h +++ b/config/s-templ.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: s-templ.h,v 1.21 2002/05/06 08:29:52 xleroy Exp $ */ +/* $Id: s-templ.h,v 1.22 2004/05/18 08:50:22 xleroy Exp $ */ /* Operating system and standard library dependencies. */ @@ -47,10 +47,6 @@ 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 diff --git a/configure b/configure index 624689a2..385676ab 100755 --- a/configure +++ b/configure @@ -13,7 +13,7 @@ # # ######################################################################### -# $Id: configure,v 1.202 2003/09/25 08:17:13 xleroy Exp $ +# $Id: configure,v 1.215.2.3 2004/07/09 15:08:51 doligez Exp $ configure_options="$*" prefix=/usr/local @@ -39,7 +39,7 @@ verbose=no withcurses=yes withsharedlibs=yes binutils_dir='' -gcc_warnings="-Wall -Wno-unused" +gcc_warnings="-Wall" # Try to turn internationalization off, can cause config.guess to malfunction! unset LANG @@ -401,11 +401,20 @@ esac # Determine alignment constraints case "$host" in - sparc-*-*) + sparc-*-*|hppa*-*-*) # 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;; + # alignment is not reliable (PR#1521), hence force it. + # Same goes for hppa. + # But there's a knack (PR#2572): + # if we're in 64-bit mode (sizeof(long) == 8), + # we must not doubleword-align floats... + if test $2 = 8; then + echo "Doubles can be word-aligned." + echo "#undef ARCH_ALIGN_DOUBLE" >> m.h + else + echo "Doubles must be doubleword-aligned." + echo "#define ARCH_ALIGN_DOUBLE" >> m.h + fi;; *) sh ./runtest dblalign.c case $? in @@ -422,17 +431,28 @@ case "$host" in 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;; + case "$host" in + hppa*-*-*) + if test $2 = 8; then + echo "64-bit integers can be word-aligned." + echo "#undef ARCH_ALIGN_INT64" >> m.h + else + echo "64-bit integers must be doubleword-aligned." + echo "#define ARCH_ALIGN_INT64" >> m.h + fi;; + *) + 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 esac else echo "#undef ARCH_ALIGN_INT64" >> m.h @@ -470,13 +490,19 @@ if test $withsharedlibs = "yes"; then 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;; + gcc*) + sharedcccompopts="-fPIC" + mksharedlib="$bytecc -shared -o" + byteccrpath="-Wl,-rpath," + mksharedlibrpath="-Wl,-rpath," + shared_libraries_supported=true;; + cc*) + sharedcccompopts="" + mksharedlib="ld -shared -expect_unresolved '*' -o" + byteccrpath="-Wl,-rpath," + mksharedlibrpath="-rpath " + shared_libraries_supported=true;; + esac;; *-*-solaris2*) case "$bytecc" in gcc*) @@ -550,16 +576,17 @@ case "$host" in mips-*-irix6*) arch=mips; system=irix;; hppa1.1-*-hpux*) arch=hppa; system=hpux;; hppa2.0*-*-hpux*) arch=hppa; system=hpux;; - hppa1.1-*-nextstep*) arch=hppa; system=nextstep;; - rs6000-*-aix*) arch=power; model=rs6000; system=aix;; - powerpc-*-aix*) arch=power; model=ppc; system=aix;; + hppa*-*-linux*) arch=hppa; system=linux;; 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;; + ia64-*-freebsd*) arch=ia64; system=freebsd;; x86_64-*-linux*) arch=amd64; system=linux;; + x86_64-*-freebsd*) arch=amd64; system=freebsd;; + x86_64-*-openbsd*) arch=amd64; system=openbsd;; esac if test -z "$ccoption"; then @@ -580,15 +607,12 @@ 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*) + *,*,rhapsody,*darwin[1-5].*) + nativecccompopts="$gcc_warnings -DSHRINKED_GNUC";; + *,*,rhapsody,*) nativecccompopts="$gcc_warnings -DDARWIN_VERSION_6 $dl_defs";; - *,*,rhapsody,*) nativecccompopts="$gcc_warnings -DSHRINKED_GNUC";; *,gcc*,cygwin,*) nativecccompopts="$gcc_warnings -U_WIN32";; *,gcc*,*,*) nativecccompopts="$gcc_warnings";; esac @@ -615,13 +639,11 @@ case "$arch,$model,$system" in 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 + ia64,*,*) asflags=-xexplicit aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM) -Wa,-xexplicit';; amd64,*,*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; esac @@ -634,6 +656,7 @@ case "$arch,$model,$system" in sparc,*,solaris) profiling='prof' case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;; + amd64,*,linux) profiling='prof';; *) profiling='noprof';; esac @@ -729,11 +752,6 @@ 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 @@ -754,7 +772,7 @@ fi # Configuration for the libraries -otherlibraries="unix str dynlink bigarray" +otherlibraries="unix str num dynlink bigarray" # For the Unix library @@ -780,6 +798,13 @@ if sh ./hasgot inet_aton; then echo "#define HAS_INET_ATON" >> s.h fi +if sh ./hasgot -i sys/types.h -i sys/socket.h -i netinet/in.h \ + -t 'struct sockaddr_in6' \ +&& sh ./hasgot getaddrinfo getnameinfo inet_pton inet_ntop; then + echo "IPv6 is supported." + echo "#define HAS_IPV6" >> s.h +fi + if sh ./hasgot -i unistd.h; then echo "unistd.h found." echo "#define HAS_UNISTD" >> s.h @@ -1020,64 +1045,55 @@ 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 + alpha*-*-*) bng_arch=alpha; bng_asm_level=1;; + i[3456]86-*-*) bng_arch=ia32 + if sh ./trycompile ia32sse2.c + then bng_asm_level=2 + else bng_asm_level=1 + fi;; + mips-*-*) bng_arch=mips; bng_asm_level=1;; + powerpc-*-*) bng_arch=ppc; bng_asm_level=1;; + sparc*-*-*) bng_arch=sparc; bng_asm_level=1;; + x86_64-*-*) bng_arch=amd64; bng_asm_level=1;; + *) bng_arch=generic; bng_asm_level=0;; esac -# 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 +echo "BNG_ARCH=$bng_arch" >> Makefile +echo "BNG_ASM_LEVEL=$bng_asm_level" >> Makefile # Determine if the POSIX threads library is supported -case "$host" in - *-*-solaris*) pthread_link="-lpthread -lposix4";; - *-*-freebsd*) pthread_link="-pthread";; - *-*-openbsd*) pthread_link="-pthread";; - *) pthread_link="-lpthread";; -esac - if test "$pthread_wanted" = "yes"; then -if ./hasgot -i pthread.h $pthread_link pthread_self; then - echo "POSIX threads library supported." - otherlibraries="$otherlibraries systhreads" - bytecccompopts="$bytecccompopts -D_REENTRANT" - nativecccompopts="$nativecccompopts -D_REENTRANT" case "$host" in - *-*-freebsd*) - bytecccompopts="$bytecccompopts -D_THREAD_SAFE" - nativecccompopts="$nativecccompopts -D_THREAD_SAFE";; - *-*-openbsd*) - bytecccompopts="$bytecccompopts -pthread" - asppflags="$asppflags -pthread" - nativecccompopts="$nativecccompopts -pthread";; + *-*-solaris*) pthread_link="-lpthread -lposix4";; + *-*-freebsd*) pthread_link="-pthread";; + *-*-openbsd*) pthread_link="-pthread";; + *) pthread_link="-lpthread";; esac - echo "Options for linking with POSIX threads: $pthread_link" - echo "PTHREAD_LINK=$pthread_link" >> Makefile - if sh ./hasgot $pthread_link sigwait; then - echo "sigwait() found" - echo "#define HAS_SIGWAIT" >> s.h + if ./hasgot -i pthread.h $pthread_link pthread_self; then + echo "POSIX threads library supported." + otherlibraries="$otherlibraries systhreads" + bytecccompopts="$bytecccompopts -D_REENTRANT" + nativecccompopts="$nativecccompopts -D_REENTRANT" + case "$host" in + *-*-freebsd*) + bytecccompopts="$bytecccompopts -D_THREAD_SAFE" + nativecccompopts="$nativecccompopts -D_THREAD_SAFE";; + *-*-openbsd*) + bytecccompopts="$bytecccompopts -pthread" + asppflags="$asppflags -pthread" + nativecccompopts="$nativecccompopts -pthread";; + esac + echo "Options for linking with POSIX threads: $pthread_link" + echo "PTHREAD_LINK=$pthread_link" >> Makefile + if sh ./hasgot $pthread_link sigwait; then + echo "sigwait() found" + echo "#define HAS_SIGWAIT" >> s.h + fi + else + echo "POSIX threads not found." + pthread_link="" fi -else - echo "POSIX threads not found." -fi fi # Determine if the bytecode thread library is supported @@ -1523,7 +1539,7 @@ echo "Additional libraries supported:" echo " $otherlibraries" echo "Configuration for the \"num\" library:" -echo " target architecture ...... $bignum_arch" +echo " target architecture ...... $bng_arch (asm level $bng_asm_level)" if test "$x11_include" != "not found" && test "$x11_lib" != "not found"; then echo "Configuration for the \"graph\" library:" diff --git a/debugger/.depend b/debugger/.depend index 433b005e..93090040 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -8,10 +8,12 @@ eval.cmi: debugcom.cmi ../typing/env.cmi ../typing/ident.cmi \ events.cmi: ../bytecomp/instruct.cmi frames.cmi: ../bytecomp/instruct.cmi primitives.cmi input_handling.cmi: primitives.cmi +lexer.cmi: parser.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 +parser_aux.cmi: ../parsing/longident.cmi primitives.cmi pattern_matching.cmi: debugcom.cmi parser_aux.cmi ../typing/typedtree.cmi +pos.cmi: ../bytecomp/instruct.cmi primitives.cmi: ../otherlibs/unix/unix.cmi printval.cmi: debugcom.cmi ../typing/env.cmi parser_aux.cmi \ ../typing/path.cmi ../typing/types.cmi @@ -21,31 +23,31 @@ 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 \ + ../bytecomp/instruct.cmi pos.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 \ + ../bytecomp/instruct.cmx pos.cmx primitives.cmx source.cmx symbols.cmx \ breakpoints.cmi checkpoints.cmo: debugcom.cmi int64ops.cmi primitives.cmi checkpoints.cmi checkpoints.cmx: debugcom.cmx int64ops.cmx primitives.cmx checkpoints.cmi command_line.cmo: breakpoints.cmi checkpoints.cmi ../utils/config.cmi \ ../typing/ctype.cmi debugcom.cmi debugger_config.cmi envaux.cmi eval.cmi \ events.cmi frames.cmi history.cmi input_handling.cmi \ - ../bytecomp/instruct.cmi int64ops.cmi ../parsing/lexer.cmi \ - loadprinter.cmi ../utils/misc.cmi parameters.cmi parser.cmi \ - parser_aux.cmi 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 + ../bytecomp/instruct.cmi int64ops.cmi lexer.cmi loadprinter.cmi \ + ../utils/misc.cmi parameters.cmi parser.cmi parser_aux.cmi pos.cmi \ + primitives.cmi printval.cmi program_loading.cmi program_management.cmi \ + show_information.cmi show_source.cmi source.cmi symbols.cmi \ + time_travel.cmi ../typing/types.cmi ../otherlibs/unix/unix.cmi \ + unix_tools.cmi command_line.cmi command_line.cmx: breakpoints.cmx checkpoints.cmx ../utils/config.cmx \ ../typing/ctype.cmx debugcom.cmx debugger_config.cmx envaux.cmx eval.cmx \ events.cmx frames.cmx history.cmx input_handling.cmx \ - ../bytecomp/instruct.cmx int64ops.cmx ../parsing/lexer.cmx \ - loadprinter.cmx ../utils/misc.cmx parameters.cmx parser.cmx \ - parser_aux.cmi 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 + ../bytecomp/instruct.cmx int64ops.cmx lexer.cmx loadprinter.cmx \ + ../utils/misc.cmx parameters.cmx parser.cmx parser_aux.cmi pos.cmx \ + primitives.cmx printval.cmx program_loading.cmx program_management.cmx \ + show_information.cmx show_source.cmx source.cmx symbols.cmx \ + time_travel.cmx ../typing/types.cmx ../otherlibs/unix/unix.cmx \ + unix_tools.cmx command_line.cmi debugcom.cmo: input_handling.cmi int64ops.cmi ../utils/misc.cmi \ primitives.cmi debugcom.cmi debugcom.cmx: input_handling.cmx int64ops.cmx ../utils/misc.cmx \ @@ -84,14 +86,14 @@ 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 +input_handling.cmo: lexer.cmi primitives.cmi ../otherlibs/unix/unix.cmi \ + input_handling.cmi +input_handling.cmx: 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 +lexer.cmo: parser.cmi primitives.cmi lexer.cmi +lexer.cmx: parser.cmx primitives.cmx lexer.cmi 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 \ @@ -103,15 +105,15 @@ loadprinter.cmx: ../utils/config.cmx ../typing/ctype.cmx debugger_config.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 + debugger_config.cmi ../typing/env.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 + debugger_config.cmx ../typing/env.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 \ @@ -126,6 +128,8 @@ pattern_matching.cmo: ../typing/ctype.cmi debugcom.cmi debugger_config.cmi \ pattern_matching.cmx: ../typing/ctype.cmx debugcom.cmx debugger_config.cmx \ ../utils/misc.cmx parser_aux.cmi ../typing/typedtree.cmx \ pattern_matching.cmi +pos.cmo: ../bytecomp/instruct.cmi primitives.cmi source.cmi pos.cmi +pos.cmx: ../bytecomp/instruct.cmx primitives.cmx source.cmx pos.cmi primitives.cmo: ../otherlibs/unix/unix.cmi primitives.cmi primitives.cmx: ../otherlibs/unix/unix.cmx primitives.cmi printval.cmo: debugcom.cmi ../toplevel/genprintval.cmi ../utils/misc.cmi \ diff --git a/debugger/Makefile b/debugger/Makefile index e739b77b..db7cc90d 100644 --- a/debugger/Makefile +++ b/debugger/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.27 2002/11/18 09:23:31 xleroy Exp $ +# $Id: Makefile,v 1.29 2004/02/22 15:07:51 xleroy Exp $ include ../config/Makefile @@ -38,8 +38,8 @@ OTHEROBJS=\ ../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 \ + ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \ + ../bytecomp/opcodes.cmo \ ../toplevel/genprintval.cmo \ ../otherlibs/dynlink/dynlink.cmo @@ -55,6 +55,7 @@ OBJS=\ debugcom.cmo \ exec.cmo \ source.cmo \ + pos.cmo \ checkpoints.cmo \ symbols.cmo \ events.cmo \ diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml index 9a055e02..0ebf2064 100644 --- a/debugger/breakpoints.ml +++ b/debugger/breakpoints.ml @@ -11,14 +11,15 @@ (* *) (***********************************************************************) -(* $Id: breakpoints.ml,v 1.11 2002/11/05 16:33:23 doligez Exp $ *) +(* $Id: breakpoints.ml,v 1.12 2003/11/21 16:10:56 doligez Exp $ *) (******************************* Breakpoints ***************************) +open Checkpoints +open Debugcom open Instruct open Primitives -open Debugcom -open Checkpoints +open Printf open Source (*** Debugging. ***) @@ -169,24 +170,8 @@ let rec new_breakpoint = 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; + printf "Breakpoint %d at %d : %s" !breakpoint_number event.ev_pos + (Pos.get_desc event); print_newline () (* Remove a breakpoint from lists. *) diff --git a/debugger/command_line.ml b/debugger/command_line.ml index 9715d3e6..3d5b883c 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: command_line.ml,v 1.17 2003/09/09 16:02:19 xleroy Exp $ *) +(* $Id: command_line.ml,v 1.21 2003/11/21 16:10:56 doligez Exp $ *) (************************ Reading and executing commands ***************) @@ -209,6 +209,14 @@ let instr_cd ppf lexbuf = | Sys_error s -> error s +let instr_shell ppf lexbuf = + let cmdarg = argument_list_eol argument lexbuf in + let cmd = String.concat " " cmdarg in + (* perhaps we should use $SHELL -c ? *) + let err = Sys.command cmd in + if (err != 0) then + eprintf "Shell command %S failed with exit code %d\n%!" cmd err + let instr_pwd ppf lexbuf = eol lexbuf; ignore(system "/bin/pwd") @@ -804,16 +812,18 @@ let info_checkpoints ppf lexbuf = Printf.printf "%19Ld %5d\n" time pid) !checkpoints)) +let info_one_breakpoint ppf (num, ev) = + fprintf ppf "%3d %10d %s@." num ev.ev_pos (Pos.get_desc ev); +;; + let info_breakpoints ppf lexbuf = eol lexbuf; - if !breakpoints = [] then fprintf ppf "No 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)) + if !breakpoints = [] then fprintf ppf "No breakpoints.@." + else begin + fprintf ppf "Num Address Where@."; + List.iter (info_one_breakpoint ppf) (List.rev !breakpoints); + end +;; let info_events ppf lexbuf = ensure_loaded (); @@ -891,6 +901,9 @@ With no argument, reset the search path." }; { instr_name = "quit"; instr_prio = false; instr_action = instr_quit; instr_repeat = false; instr_help = "exit the debugger." }; + { instr_name = "shell"; instr_prio = false; + instr_action = instr_shell; instr_repeat = true; instr_help = +"Execute a given COMMAND thru the system shell." }; (* Displacements *) { instr_name = "run"; instr_prio = true; instr_action = instr_run; instr_repeat = true; instr_help = diff --git a/debugger/lexer.mli b/debugger/lexer.mli new file mode 100644 index 00000000..df7cfad2 --- /dev/null +++ b/debugger/lexer.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: lexer.mli,v 1.1 2004/06/13 12:46:11 xleroy Exp $ *) + +val line: Lexing.lexbuf -> string +val lexeme: Lexing.lexbuf -> Parser.token +val argument: Lexing.lexbuf -> Parser.token +val line_argument: Lexing.lexbuf -> Parser.token diff --git a/debugger/main.ml b/debugger/main.ml index 86121315..12481310 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: main.ml,v 1.13 2002/11/02 22:36:42 doligez Exp $ *) +(* $Id: main.ml,v 1.15 2003/12/04 12:32:04 starynke Exp $ *) open Primitives open Misc @@ -125,8 +125,14 @@ let main () = toplevel_loop (); (* Toplevel. *) kill_program (); exit 0 - with Toplevel -> - exit 2 + with + Toplevel -> + exit 2 + | Env.Error e -> + eprintf "Debugger [version %s] environment error:@ @[@;" Config.version; + Env.report_error err_formatter e; + eprintf "@]@."; + exit 2 let _ = Printexc.catch (Unix.handle_unix_error main) () diff --git a/debugger/pos.ml b/debugger/pos.ml new file mode 100644 index 00000000..a4f7880c --- /dev/null +++ b/debugger/pos.ml @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* 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: pos.ml,v 1.1 2003/11/21 16:10:56 doligez Exp $ *) + +open Instruct;; +open Lexing;; +open Primitives;; +open Source;; + +let get_desc ev = + if ev.ev_char.pos_fname <> "" + then Printf.sprintf "file %s, line %d, character %d" + ev.ev_char.pos_fname ev.ev_char.pos_lnum + (ev.ev_char.pos_cnum - ev.ev_char.pos_bol + 1) + else begin + let filename = source_of_module ev.ev_module in + try + let (start, line) = line_of_pos (get_buffer ev.ev_module) + ev.ev_char.pos_cnum + in + Printf.sprintf "file %s, line %d, character %d" + filename line (ev.ev_char.pos_cnum - start + 1) + with Not_found | Out_of_range -> + Printf.sprintf "file %s, character %d" + filename (ev.ev_char.pos_cnum + 1) + end +;; diff --git a/debugger/pos.mli b/debugger/pos.mli new file mode 100644 index 00000000..9cfbdd47 --- /dev/null +++ b/debugger/pos.mli @@ -0,0 +1,15 @@ +(***********************************************************************) +(* *) +(* 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: pos.mli,v 1.1 2003/11/21 16:10:57 doligez Exp $ *) + +val get_desc : Instruct.debug_event -> string;; diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml index 0e607c04..0066b5da 100644 --- a/debugger/time_travel.ml +++ b/debugger/time_travel.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: time_travel.ml,v 1.16 2002/10/29 17:53:24 doligez Exp $ *) +(* $Id: time_travel.ml,v 1.17 2004/06/21 08:39:32 xleroy Exp $ *) (**************************** Time travel ******************************) @@ -385,7 +385,7 @@ let forget_process fd pid = 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 + if checkpoint == !current_checkpoint then begin Printf.eprintf " (active process)\n"; match !current_checkpoint.c_state with C_stopped -> @@ -403,7 +403,7 @@ let forget_process fd pid = 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 + if checkpoint == !current_checkpoint then raise Current_checkpoint_lost (* Try to recover when the current checkpoint is lost. *) diff --git a/driver/compile.ml b/driver/compile.ml index 7bfe042b..e5844da9 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: compile.ml,v 1.53 2003/07/25 12:17:18 xleroy Exp $ *) +(* $Id: compile.ml,v 1.54 2004/06/13 12:46:41 xleroy Exp $ *) (* The batch compiler *) @@ -50,10 +50,10 @@ let initial_env () = (* Compile a .mli file *) -let interface ppf sourcefile = +let interface ppf sourcefile outputprefix = init_path(); - let prefixname = chop_extension_if_any sourcefile in - let modulename = String.capitalize(Filename.basename prefixname) in + let modulename = + String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in let inputfile = Pparse.preprocess sourcefile in try let ast = @@ -65,7 +65,7 @@ let interface ppf sourcefile = (Typemod.simplify_signature sg); Warnings.check_fatal (); if not !Clflags.print_types then - Env.save_signature sg modulename (prefixname ^ ".cmi"); + Env.save_signature sg modulename (outputprefix ^ ".cmi"); Pparse.remove_preprocessed inputfile with e -> Pparse.remove_preprocessed_if_ast inputfile; @@ -79,27 +79,27 @@ let print_if ppf flag printer arg = let (++) x f = f x -let implementation ppf sourcefile = +let implementation ppf sourcefile outputprefix = init_path(); - let prefixname = chop_extension_if_any sourcefile in - let modulename = String.capitalize(Filename.basename prefixname) in + let modulename = + String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) 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) + ++ Typemod.type_implementation sourcefile outputprefix modulename env) with x -> Pparse.remove_preprocessed_if_ast inputfile; raise x end else begin - let objfile = prefixname ^ ".cmo" in + let objfile = outputprefix ^ ".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 + ++ Typemod.type_implementation sourcefile outputprefix modulename env ++ Translmod.transl_implementation modulename ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda ++ Simplif.simplify_lambda diff --git a/driver/compile.mli b/driver/compile.mli index bacb06ad..07286e0f 100644 --- a/driver/compile.mli +++ b/driver/compile.mli @@ -10,14 +10,14 @@ (* *) (***********************************************************************) -(* $Id: compile.mli,v 1.7 2000/03/06 22:11:30 weis Exp $ *) +(* $Id: compile.mli,v 1.8 2004/06/13 12:46:41 xleroy Exp $ *) (* Compile a .ml or .mli file *) open Format -val interface: formatter -> string -> unit -val implementation: formatter -> string -> unit +val interface: formatter -> string -> string -> unit +val implementation: formatter -> string -> string -> unit val c_file: string -> unit val initial_env: unit -> Env.t diff --git a/driver/main.ml b/driver/main.ml index fab38463..c321dd73 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -10,29 +10,43 @@ (* *) (***********************************************************************) -(* $Id: main.ml,v 1.64 2003/07/17 08:38:27 xleroy Exp $ *) +(* $Id: main.ml,v 1.67 2004/06/13 12:46:41 xleroy Exp $ *) open Config open Clflags +let output_prefix name = + let oname = + match !output_name with + | None -> name + | Some n -> if !compile_only then (output_name := None; n) else name in + Misc.chop_extension_if_any oname + let process_interface_file ppf name = - Compile.interface ppf name + Compile.interface ppf name (output_prefix name) let process_implementation_file ppf name = - Compile.implementation ppf name; - objfiles := (Misc.chop_extension_if_any name ^ ".cmo") :: !objfiles + let opref = output_prefix name in + Compile.implementation ppf name opref; + objfiles := (opref ^ ".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 + let opref = output_prefix name in + Compile.implementation ppf name opref; + objfiles := (opref ^ ".cmo") :: !objfiles + end + else if Filename.check_suffix name !Config.interface_suffix then begin + let opref = output_prefix name in + Compile.interface ppf name opref; + if !make_package then objfiles := (opref ^ ".cmi") :: !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 ".cmi" && !make_package then + objfiles := name :: !objfiles else if Filename.check_suffix name ext_obj || Filename.check_suffix name ext_lib then ccobjs := name :: !ccobjs @@ -40,11 +54,8 @@ let process_file ppf name = 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 + ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj) + :: !ccobjs end else raise(Arg.Bad("don't know what to do with " ^ name)) diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 143ba525..90dfc57c 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: optcompile.ml,v 1.47 2003/07/25 12:17:19 xleroy Exp $ *) +(* $Id: optcompile.ml,v 1.48 2004/06/13 12:46:41 xleroy Exp $ *) (* The batch compiler *) @@ -47,10 +47,10 @@ let initial_env () = (* Compile a .mli file *) -let interface ppf sourcefile = +let interface ppf sourcefile outputprefix = init_path(); - let prefixname = Misc.chop_extension_if_any sourcefile in - let modulename = String.capitalize(Filename.basename prefixname) in + let modulename = + String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in let inputfile = Pparse.preprocess sourcefile in try let ast = @@ -62,7 +62,7 @@ let interface ppf sourcefile = (Typemod.simplify_signature sg); Warnings.check_fatal (); if not !Clflags.print_types then - Env.save_signature sg modulename (prefixname ^ ".cmi"); + Env.save_signature sg modulename (outputprefix ^ ".cmi"); Pparse.remove_preprocessed inputfile with e -> Pparse.remove_preprocessed_if_ast inputfile; @@ -77,10 +77,10 @@ let print_if ppf flag printer arg = let (++) x f = f x let (+++) (x, y) f = (x, f y) -let implementation ppf sourcefile = +let implementation ppf sourcefile outputprefix = init_path(); - let prefixname = Misc.chop_extension_if_any sourcefile in - let modulename = String.capitalize(Filename.basename prefixname) in + let modulename = + String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in let inputfile = Pparse.preprocess sourcefile in let env = initial_env() in Compilenv.reset modulename; @@ -88,17 +88,17 @@ let implementation ppf sourcefile = 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) + ++ Typemod.type_implementation sourcefile outputprefix 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 + ++ Typemod.type_implementation sourcefile outputprefix 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"); + ++ Asmgen.compile_implementation outputprefix ppf; + Compilenv.save_unit_info (outputprefix ^ ".cmx"); end; Warnings.check_fatal (); Pparse.remove_preprocessed inputfile diff --git a/driver/optcompile.mli b/driver/optcompile.mli index 83dc75dd..7f6f037e 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -10,14 +10,14 @@ (* *) (***********************************************************************) -(* $Id: optcompile.mli,v 1.7 2000/03/07 05:02:32 garrigue Exp $ *) +(* $Id: optcompile.mli,v 1.8 2004/06/13 12:46:41 xleroy Exp $ *) (* Compile a .ml or .mli file *) open Format -val interface: formatter -> string -> unit -val implementation: formatter -> string -> unit +val interface: formatter -> string -> string -> unit +val implementation: formatter -> string -> string -> unit val c_file: string -> unit val initial_env: unit -> Env.t diff --git a/driver/optmain.ml b/driver/optmain.ml index fa36152b..30fda313 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -10,36 +10,50 @@ (* *) (***********************************************************************) -(* $Id: optmain.ml,v 1.79 2003/07/17 08:38:27 xleroy Exp $ *) +(* $Id: optmain.ml,v 1.81 2004/06/13 12:46:41 xleroy Exp $ *) open Config open Clflags +let output_prefix name = + let oname = + match !output_name with + | None -> name + | Some n -> if !compile_only then (output_name := None; n) else name in + Misc.chop_extension_if_any oname + let process_interface_file ppf name = - Optcompile.interface ppf name + Optcompile.interface ppf name (output_prefix name) let process_implementation_file ppf name = - Optcompile.implementation ppf name; - objfiles := (Misc.chop_extension_if_any name ^ ".cmx") :: !objfiles + let opref = output_prefix name in + Optcompile.implementation ppf name opref; + objfiles := (opref ^ ".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 + let opref = output_prefix name in + Optcompile.implementation ppf name opref; + objfiles := (opref ^ ".cmx") :: !objfiles + end + else if Filename.check_suffix name !Config.interface_suffix then begin + let opref = output_prefix name in + Optcompile.interface ppf name opref; + if !make_package then objfiles := (opref ^ ".cmi") :: !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 ".cmi" && !make_package 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 + :: !ccobjs end else raise(Arg.Bad("don't know what to do with " ^ name)) diff --git a/driver/pparse.ml b/driver/pparse.ml index 1fa79938..acdc08bd 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pparse.ml,v 1.2 2002/11/01 17:06:42 doligez Exp $ *) +(* $Id: pparse.ml,v 1.3 2004/06/16 16:58:46 doligez Exp $ *) open Format @@ -23,7 +23,9 @@ let preprocess sourcefile = None -> sourcefile | Some pp -> let tmpfile = Filename.temp_file "camlpp" "" in - let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in + let comm = Printf.sprintf "%s %s > %s" + pp (Filename.quote sourcefile) tmpfile + in if Ccomp.command comm <> 0 then begin Misc.remove_file tmpfile; raise Error; diff --git a/emacs/caml-emacs.el b/emacs/caml-emacs.el index b212db65..5f35c245 100644 --- a/emacs/caml-emacs.el +++ b/emacs/caml-emacs.el @@ -5,10 +5,25 @@ (defalias 'caml-line-beginning-position 'line-beginning-position) +(defalias 'caml-read-event 'read-event) +(defalias 'caml-window-edges 'window-edges) +(defun caml-mouse-vertical-position () + (cddr (mouse-position))) +(defalias 'caml-ignore-event-p 'integer-or-marker-p) +(defalias 'caml-mouse-movement-p 'mouse-movement-p) +(defalias 'caml-sit-for 'sit-for) + +(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body)) + (defun caml-event-window (e) (posn-window (event-start e))) (defun caml-event-point-start (e) (posn-point (event-start e))) (defun caml-event-point-end (e) (posn-point (event-end e))) -(defalias 'caml-read-event 'read-event) -(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body)) + +(defun caml-release-event-p (original event) + (and (equal (event-basic-type original) (event-basic-type event)) + (let ((modifiers (event-modifiers event))) + (or (member 'drag modifiers) + (member 'click modifiers))))) + (provide 'caml-emacs) diff --git a/emacs/caml-font.el b/emacs/caml-font.el index 678b2a50..628a757e 100644 --- a/emacs/caml-font.el +++ b/emacs/caml-font.el @@ -2,8 +2,9 @@ (cond ((x-display-color-p) + (require 'font-lock) (cond - ((not (memq 'font-lock-type-face (face-list))) + ((not (boundp 'font-lock-type-face)) ; make the necessary faces (make-face 'Firebrick) (set-face-foreground 'Firebrick "Firebrick") diff --git a/emacs/caml-help.el b/emacs/caml-help.el index d2a448b4..ea082bf2 100644 --- a/emacs/caml-help.el +++ b/emacs/caml-help.el @@ -560,7 +560,7 @@ command. An entry may be an info module or a complete file name." ;; Help function. -(defun ocaml-goto-help (&optional module entry) +(defun ocaml-goto-help (&optional module entry same-window) "Searches info manual for MODULE and ENTRY in MODULE. If unspecified, MODULE and ENTRY are inferred from the position in the current buffer using \\[ocaml-qualified-identifier]." @@ -578,9 +578,14 @@ current buffer using \\[ocaml-qualified-identifier]." (location (cdr (cadr module-info)))) (cond (location - (view-file-other-window - (concat location (ocaml-uncapitalize module) ".mli")) - (bury-buffer (current-buffer))) + (let ((file (concat location (ocaml-uncapitalize module) ".mli"))) + (if (window-live-p same-window) + (progn (select-window same-window) + (view-mode-exit view-return-to-alist view-exit-action)) + ;; (view-buffer (find-file-noselect file) 'view)) + ) + (view-file-other-window file) + (bury-buffer (current-buffer)))) (info-section (error "Aborted")) (t (error "No help for module %s" module)))) ) @@ -589,7 +594,7 @@ current buffer using \\[ocaml-qualified-identifier]." (case-fold-search nil)) (goto-char (point-min)) (if (or (re-search-forward - (concat "\\(val\\|exception\\|external\\|[|{;]\\) +" + (concat "\\(val\\|exception\\|type\\|external\\|[|{;]\\) +" (regexp-quote entry)) (point-max) t) (re-search-forward @@ -597,7 +602,7 @@ current buffer using \\[ocaml-qualified-identifier]." (point-max) t) (progn (if (window-live-p window) (select-window window)) - (error "Entry %S not found in module %S" + (error "Entry %s not found in module %s" entry module)) ;; (search-forward entry (point-max) t) ) @@ -698,21 +703,22 @@ 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)) - )))) + (cdr + (if (and ocaml-links section (equal (car ocaml-links) section)) + ocaml-links + (save-excursion + (goto-char (point-min)) + (let ((regexp (concat (if (equal major-mode 'Info-mode) "^ - " "^") + ocaml-link-regexp)) + (all)) + (while (re-search-forward regexp (point-max) t) + (setq all + (cons (cons (match-string 4) + (cons (match-beginning 4) + (match-end 4))) + all))) + (setq ocaml-links (cons section all)) + ))))) (defvar ocaml-link-map (make-sparse-keymap)) (define-key ocaml-link-map [mouse-2] 'ocaml-link-goto) @@ -720,17 +726,19 @@ buffer positions." (defun ocaml-link-goto (click) (interactive "e") (let* ((pos (caml-event-point-start click)) - (buf (window-buffer (caml-event-window click))) + (win (caml-event-window click)) + (buf (window-buffer win)) (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))))) + (buffer-substring + (previous-single-property-change (+ pos 1) 'local-map + buf (- pos 100)) + (next-single-property-change pos 'local-map + buf (+ pos 100))))) (if (string-match (concat "^" ocaml-longident-regexp "$") link) - (ocaml-goto-help (match-string 1 link) (match-string 2 link)) + (ocaml-goto-help (match-string 1 link) (match-string 2 link) win) (if (not (equal (window-buffer window) buf)) (switch-to-buffer-other-window buf)) (if (setq link (assoc link (cdr ocaml-links))) @@ -748,28 +756,33 @@ buffer positions." (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) + (let ((links (ocaml-info-links section))) + (if links + (let ((regexp (concat "[^A-Za-z0-9'_]\\(" + ocaml-longident-regexp "\\|" + (mapconcat 'car links "\\|") + "\\)[^A-Za-z0-9'_]")) + (case-fold-search nil)) + (goto-char (point-min)) + (let ((buffer-read-only nil) + ;; use of dynamic scoping, need not be restored! + (modified-p (buffer-modified-p))) + (unwind-protect + (save-excursion + (goto-char (point-min)) + (while (re-search-forward regexp (point-max) t) (put-text-property (match-beginning 1) (match-end 1) - 'face 'ocaml-link-face))) - ) - (setq buffer-read-only t)) - ))) + 'mouse-face 'highlight) + (put-text-property (match-beginning 1) (match-end 1) + 'local-map ocaml-link-map) + (if (x-display-color-p) + (put-text-property (match-beginning 1) (match-end 1) + 'face 'ocaml-link-face))) + ) + ;; need to restore flag if buffer was unmodified. + (unless modified-p (set-buffer-modified-p nil)) + )) + )))) diff --git a/emacs/caml-types.el b/emacs/caml-types.el index d8654ce9..571d2387 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-types.el,v 1.26 2003/10/11 00:00:14 doligez Exp $ *) +;(* $Id: caml-types.el,v 1.29 2003/10/21 07:36:06 remy Exp $ *) ; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt. @@ -153,7 +153,7 @@ See `caml-types-location-re' for annotation file format. (not (window-live-p (get-buffer-window caml-types-buffer)))) (display-buffer caml-types-buffer)) (unwind-protect - (sit-for 60) + (caml-sit-for 60) (delete-overlay caml-types-expr-ovl) ))) @@ -388,11 +388,23 @@ See `caml-types-location-re' for annotation file format. (interactive "e") nil) +(defun caml-types-time () + (let ((time (current-time))) + (+ (* (mod (cadr time) 1000) 1000) + (/ (cadr (cdr time)) 1000)))) + (defun caml-types-explore (event) "Explore type annotations by mouse dragging. -The expression under the mouse is highlighted -and its type is displayed in the minibuffer, until the move is released." +The expression under the mouse is highlighted and its type is displayed +in the minibuffer, until the move is released, much as `caml-types-show-type'. +The function uses two overlays. + + . One overlay delimits the largest region whose all subnodes + are well-typed. + . Another overlay delimits the current node under the mouse (whose type + annotation is beeing displayed). +" (interactive "e") (set-buffer (window-buffer (caml-event-window event))) (let* ((target-buf (current-buffer)) @@ -403,8 +415,13 @@ and its type is displayed in the minibuffer, until the move is released." target-pos Left Right limits cnum node mes type region + (window (caml-event-window event)) target-tree + (speed 100) + (last-time (caml-types-time)) + (original-event event) ) + (select-window window) (unwind-protect (progn (caml-types-preprocess type-file) @@ -415,66 +432,121 @@ and its type is displayed in the minibuffer, until the move is released." ;; (message "Drag the mouse to explore types") (unwind-protect (caml-track-mouse - (setq region - (caml-types-typed-make-overlay - target-buf (caml-event-point-start event))) - (while (and event - (integer-or-marker-p - (setq cnum (caml-event-point-end event)))) - (if (and region (<= (car region) cnum) (< cnum (cdr region))) - (if (and limits - (>= cnum (car limits)) (< cnum (cdr limits))) - (message mes) - (setq target-bol - (save-excursion - (goto-char cnum) (caml-line-beginning-position)) - target-line (1+ (count-lines (point-min) - target-bol)) - target-pos - (vector target-file target-line target-bol cnum)) - (save-excursion - (setq node (caml-types-find-location - target-pos () target-tree)) - (set-buffer caml-types-buffer) - (erase-buffer) - (cond - (node - (setq Left - (caml-types-get-pos target-buf (elt node 0)) - Right - (caml-types-get-pos target-buf (elt node 1))) - (move-overlay - caml-types-expr-ovl Left Right target-buf) - (setq limits - (caml-types-find-interval target-buf - target-pos node) - type (elt node 2)) - ) - (t - (delete-overlay caml-types-expr-ovl) - (setq type "*no type information*") - (setq limits - (caml-types-find-interval - target-buf target-pos target-tree)) - )) - (message (setq mes (format "type: %s" type))) - (insert type) - ))) - (setq event (caml-read-event)) - (unless (mouse-movement-p event) (setq event nil)) + (while event + (cond + ;; we ignore non mouse events + ((caml-ignore-event-p event)) + ;; we stop when the original button is released + ((caml-release-event-p original-event event) + (setq event nil)) + ;; we scroll when the motion is outside the window + ((and (caml-mouse-movement-p event) + (not (and (equal window (caml-event-window event)) + (integer-or-marker-p + (caml-event-point-end event))))) + (let* ((win (caml-window-edges window)) + (top (nth 1 win)) + (bottom (- (nth 3 win) 1)) + mouse + time + ) + (while (and + (caml-sit-for 0 (/ 500 speed)) + (setq time (caml-types-time)) + (> (- time last-time) (/ 500 speed)) + (setq mouse (caml-mouse-vertical-position)) + (or (< mouse top) (>= mouse bottom)) + ) + (setq last-time time) + (cond + ((< mouse top) + (setq speed (- top mouse)) + (condition-case nil + (scroll-down 1) + (error (message "Beginning of buffer!")))) + ((>= mouse bottom) + (setq speed (+ 1 (- mouse bottom))) + (condition-case nil + (scroll-up 1) + (error (message "End of buffer!")))) + ) + (setq speed (* speed speed)) + ))) + ;; main action, when the motion is inside the window + ;; or on orginal button down event + ((or (caml-mouse-movement-p event) + (equal original-event event)) + (setq cnum (caml-event-point-end event)) + (if (and region + (<= (car region) cnum) (< cnum (cdr region))) + ;; mouse remains in outer region + nil + ;; otherwise, reset the outer region + (setq region + (caml-types-typed-make-overlay + target-buf (caml-event-point-start event)))) + (if + (and limits + (>= cnum (car limits)) (< cnum (cdr limits))) + ;; inner region is unchanged + nil + ;; recompute the inner region and type annotation + (setq target-bol + (save-excursion + (goto-char cnum) (caml-line-beginning-position)) + target-line (1+ (count-lines (point-min) + target-bol)) + target-pos + (vector target-file target-line target-bol cnum)) + (save-excursion + (setq node (caml-types-find-location + target-pos () target-tree)) + (set-buffer caml-types-buffer) + (erase-buffer) + (cond + (node + (setq Left + (caml-types-get-pos target-buf (elt node 0)) + Right + (caml-types-get-pos target-buf (elt node 1))) + (move-overlay + caml-types-expr-ovl Left Right target-buf) + (setq limits + (caml-types-find-interval target-buf + target-pos node) + type (elt node 2)) + ) + (t + (delete-overlay caml-types-expr-ovl) + (setq type "*no type information*") + (setq limits + (caml-types-find-interval + target-buf target-pos target-tree)) + )) + (setq mes (format "type: %s" type)) + (insert type) + )) + (message mes) + ) + ) + ;; we read next event, unless it is nil, and loop back. + (if event (setq event (caml-read-event))) ) ) + ;; delete overlays at end of exploration (delete-overlay caml-types-expr-ovl) (delete-overlay caml-types-typed-ovl) )) - ;; the mouse is down. One should prevent against mouse release, - ;; which could do something undesirable. - ;; In most common cases, next event will be mouse release. + ;; When an error occurs, the mouse release event has not been read. + ;; We could wait for mouse release to prevent execution of + ;; a binding of mouse release, such as cut or paste. + ;; In most common cases, next event will be the mouse release. ;; However, it could also be a key stroke before mouse release. - ;; Will then execute the action for mouse release (if bound). ;; Emacs does not allow to test whether mouse is up or down. - ;; Same problem may happen above while exploring - (if (and event (caml-read-event))) + ;; Not sure it is robust to loop for mouse release after an error + ;; occured, as is done for exploration. + ;; So far, we just ignore next event. (Next line also be uncommenting.) + (if event (caml-read-event)) ))) (defun caml-types-typed-make-overlay (target-buf pos) diff --git a/emacs/caml-xemacs.el b/emacs/caml-xemacs.el index b1b01bd6..ff493915 100644 --- a/emacs/caml-xemacs.el +++ b/emacs/caml-xemacs.el @@ -9,12 +9,31 @@ (defun caml-line-beginning-position () (save-excursion (beginning-of-line) (point))) -(defun caml-event-window (e) (event-window e)) +(defalias 'caml-read-event 'next-event) +(defalias 'caml-window-edges 'window-pixel-edges) +(defun caml-mouse-vertical-position () + (let ((e (mouse-position-as-motion-event))) + (and e (event-y-pixel e)))) +(defalias 'caml-mouse-movement-p 'motion-event-p) +(defun caml-event-window (e) + (and (mouse-event-p e) (event-window e))) (defun caml-event-point-start (e) (event-closest-point e)) (defun caml-event-point-end (e) (event-closest-point e)) -(defalias 'caml-read-event 'next-event) +(defun caml-ignore-event-p (e) + (if (and (key-press-event-p e) (equal (key-binding e) 'keyboard-quit)) + (keyboard-quit)) + (not (mouse-event-p e))) + + +(defun caml-sit-for (sec &optional mili) + (sit-for (+ sec (if mili (* 0.001 mili))))) + + + (defmacro caml-track-mouse (&rest body) (cons 'progn body)) -(defun mouse-movement-p (e) (equal (event-type e) 'motion)) +(defun caml-release-event-p (original event) + (and (button-release-event-p event) + (equal (event-button original) (event-button event)))) (provide 'caml-xemacs) diff --git a/emacs/caml.el b/emacs/caml.el index 74ad3731..8e6da6a2 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -283,9 +283,8 @@ have caml-electric-indent on, which see.") ;; caml-types (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type) - ;; to prevent misbehavior in case of error during exploration. - (define-key caml-mode-map [mouse-2] 'caml-types-mouse-ignore) - (define-key caml-mode-map [down-mouse-2] 'caml-types-explore) + ;; must be a mouse-down event. Can be any button and any prefix + (define-key caml-mode-map [?\C-c down-mouse-1] 'caml-types-explore) ;; caml-help (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path) (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module) diff --git a/emacs/camldebug.el b/emacs/camldebug.el index 8d7b856e..c66343a4 100644 --- a/emacs/camldebug.el +++ b/emacs/camldebug.el @@ -463,7 +463,7 @@ around point." ;;;###autoload (defvar camldebug-command-name "ocamldebug" - "Pathname for executing camldebug.") + "*Pathname for executing camldebug.") ;;;###autoload (defun camldebug (path) diff --git a/lex/.depend b/lex/.depend index b21bfd93..f90d6dc6 100644 --- a/lex/.depend +++ b/lex/.depend @@ -16,9 +16,9 @@ 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 \ +main.cmo: common.cmi compact.cmi cset.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 \ +main.cmx: common.cmx compact.cmx cset.cmx lexer.cmx lexgen.cmx output.cmx \ outputbis.cmx parser.cmx syntax.cmx output.cmo: common.cmi compact.cmi lexgen.cmi syntax.cmi output.cmi output.cmx: common.cmx compact.cmx lexgen.cmx syntax.cmx output.cmi diff --git a/lex/Makefile.Mac b/lex/Makefile.Mac deleted file mode 100644 index db2baf06..00000000 --- a/lex/Makefile.Mac +++ /dev/null @@ -1,63 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id: 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 deleted file mode 100644 index 73e2f7f3..00000000 --- a/lex/Makefile.Mac.depend +++ /dev/null @@ -1,17 +0,0 @@ -compact.cmiÄ lexgen.cmi -lexer.cmiÄ parser.cmi -lexgen.cmiÄ syntax.cmi -output.cmiÄ compact.cmi lexgen.cmi syntax.cmi -parser.cmiÄ syntax.cmi -compact.cmoÄ lexgen.cmi compact.cmi -compact.cmxÄ lexgen.cmx compact.cmi -lexer.cmoÄ parser.cmi syntax.cmi lexer.cmi -lexer.cmxÄ parser.cmx syntax.cmi lexer.cmi -lexgen.cmoÄ syntax.cmi lexgen.cmi -lexgen.cmxÄ syntax.cmi lexgen.cmi -main.cmoÄ compact.cmi lexer.cmi lexgen.cmi output.cmi parser.cmi syntax.cmi -main.cmxÄ compact.cmx lexer.cmx lexgen.cmx output.cmx parser.cmx syntax.cmi -output.cmoÄ compact.cmi lexgen.cmi syntax.cmi output.cmi -output.cmxÄ compact.cmx lexgen.cmx syntax.cmi output.cmi -parser.cmoÄ syntax.cmi parser.cmi -parser.cmxÄ syntax.cmi parser.cmi diff --git a/lex/cset.ml b/lex/cset.ml index 84c2a771..8a7515c9 100644 --- a/lex/cset.ml +++ b/lex/cset.ml @@ -11,6 +11,11 @@ (* *) (***********************************************************************) +(* $Id: cset.ml,v 1.3 2004/04/29 11:12:49 maranget Exp $ *) + + +exception Bad + type t = (int * int) list diff --git a/lex/cset.mli b/lex/cset.mli index 0ebcac0e..48496037 100644 --- a/lex/cset.mli +++ b/lex/cset.mli @@ -11,13 +11,18 @@ (* *) (***********************************************************************) +(* $Id: cset.mli,v 1.3 2004/04/29 11:12:49 maranget Exp $ *) + (* Set of characters encoded as list of intervals *) type t +exception Bad val empty : t val is_empty : t -> bool val all_chars : t +exception Bad + val all_chars_eof : t val eof : t val singleton : int -> t diff --git a/lex/lexer.mli b/lex/lexer.mli index 5c66bc4d..dfc3eca1 100644 --- a/lex/lexer.mli +++ b/lex/lexer.mli @@ -10,11 +10,13 @@ (* *) (***********************************************************************) -(* $Id: lexer.mli,v 1.5 1999/11/17 18:57:33 xleroy Exp $ *) +(* $Id: lexer.mli,v 1.6 2004/04/21 23:26:05 doligez Exp $ *) val main: Lexing.lexbuf -> Parser.token -exception Lexical_error of string * int * int +exception Lexical_error of string * string * int * int +(*n val line_num: int ref val line_start_pos: int ref +*) diff --git a/lex/lexer.mll b/lex/lexer.mll index 8a173f45..cb6add81 100644 --- a/lex/lexer.mll +++ b/lex/lexer.mll @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lexer.mll,v 1.19 2002/10/31 14:21:20 maranget Exp $ *) +(* $Id: lexer.mll,v 1.21 2004/04/29 11:12:49 maranget Exp $ *) (* The lexical analyzer for lexer definitions. Bootstrapped! *) @@ -25,7 +25,7 @@ and comment_depth = ref 0 let in_pattern () = !brace_depth = 0 && !comment_depth = 0 -exception Lexical_error of string * int * int +exception Lexical_error of string * string * int * int let string_buff = Buffer.create 256 @@ -42,24 +42,32 @@ let char_for_backslash = function | 'r' -> '\r' | c -> c - -let line_num = ref 1 -let line_start_pos = ref 0 +let raise_lexical_error lexbuf msg = + let p = Lexing.lexeme_start_p lexbuf in + raise (Lexical_error (msg, + p.Lexing.pos_fname, + p.Lexing.pos_lnum, + p.Lexing.pos_cnum - p.Lexing.pos_bol + 1)) +;; let handle_lexical_error fn lexbuf = - let line = !line_num - and column = Lexing.lexeme_start lexbuf - !line_start_pos + 1 in + let p = Lexing.lexeme_start_p lexbuf in + let line = p.Lexing.pos_lnum + and column = p.Lexing.pos_cnum - p.Lexing.pos_bol + 1 + and file = p.Lexing.pos_fname + in try fn lexbuf - with Lexical_error (msg, 0, 0) -> - raise(Lexical_error(msg, line, column)) + with Lexical_error (msg, "", 0, 0) -> + raise(Lexical_error(msg, file, line, column)) let get_input_name () = Sys.argv.(Array.length Sys.argv - 1) let warning lexbuf msg = + let p = Lexing.lexeme_start_p lexbuf in 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; + p.Lexing.pos_fname p.Lexing.pos_lnum + (p.Lexing.pos_cnum - p.Lexing.pos_bol + 1) msg; flush stderr let decimal_code c d u = @@ -78,6 +86,27 @@ let char_for_hexadecimal_code d u = in Char.chr (val1 * 16 + val2) +let incr_loc lexbuf delta = + let pos = lexbuf.Lexing.lex_curr_p in + lexbuf.Lexing.lex_curr_p <- { pos with + Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; + Lexing.pos_bol = pos.Lexing.pos_cnum - delta; + } +;; + +let update_loc lexbuf opt_file line = + let pos = lexbuf.Lexing.lex_curr_p in + let new_file = match opt_file with + | None -> pos.Lexing.pos_fname + | Some f -> f + in + lexbuf.Lexing.lex_curr_p <- { pos with + Lexing.pos_fname = new_file; + Lexing.pos_lnum = line; + Lexing.pos_bol = pos.Lexing.pos_cnum; + } +;; + } let identstart = @@ -91,9 +120,14 @@ rule main = parse [' ' '\013' '\009' '\012' ] + { main lexbuf } | '\010' - { line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num; + { incr_loc lexbuf 0; main lexbuf } + | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* + ('\"' ([^ '\010' '\013' '\"']* as name) '\"')? + [^ '\010' '\013']* '\010' + { update_loc lexbuf name (int_of_string num); + main lexbuf + } | "(*" { comment_depth := 1; handle_lexical_error comment lexbuf; @@ -121,25 +155,22 @@ rule main = parse | "'" '\\' (['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)) + raise_lexical_error lexbuf + (Printf.sprintf "illegal escape sequence \\%c%c%c" c d u) 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)) + { raise_lexical_error lexbuf + (Printf.sprintf "illegal escape sequence \\%c" c) } | '{' - { let n1 = Lexing.lexeme_end lexbuf - and l1 = !line_num - and s1 = !line_start_pos in + { let p = Lexing.lexeme_end_p lexbuf in + let n1 = p.Lexing.pos_cnum + and l1 = p.Lexing.pos_lnum + and s1 = p.Lexing.pos_bol in brace_depth := 1; let n2 = handle_lexical_error action lexbuf in Taction({start_pos = n1; end_pos = n2; @@ -155,20 +186,20 @@ rule main = parse | ')' { Trparen } | '^' { Tcaret } | '-' { Tdash } + | '#' { Tsharp } | eof { Tend } | _ - { raise(Lexical_error - ("illegal character " ^ String.escaped(Lexing.lexeme lexbuf), - !line_num, Lexing.lexeme_start lexbuf - !line_start_pos+1)) } + { raise_lexical_error lexbuf + ("illegal character " ^ String.escaped(Lexing.lexeme lexbuf)) + } (* 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; + | '\\' ("\010" | "\013" | "\013\010") ([' ' '\009'] * as spaces) + { incr_loc lexbuf (String.length spaces); string lexbuf } | '\\' (backslash_escapes as c) { store_string_char(char_for_backslash c); @@ -192,11 +223,10 @@ and string = parse store_string_char c ; string lexbuf } | eof - { raise(Lexical_error("unterminated string", 0, 0)) } + { raise(Lexical_error("unterminated string", "", 0, 0)) } | '\010' { store_string_char '\010'; - line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num; + incr_loc lexbuf 0; string lexbuf } | _ as c { store_string_char c; @@ -223,10 +253,9 @@ and comment = parse { skip_char lexbuf ; comment lexbuf } | eof - { raise(Lexical_error("unterminated comment", 0, 0)) } + { raise(Lexical_error("unterminated comment", "", 0, 0)) } | '\010' - { line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num; + { incr_loc lexbuf 0; comment lexbuf } | _ { comment lexbuf } @@ -251,18 +280,17 @@ and action = parse comment lexbuf; action lexbuf } | eof - { raise (Lexical_error("unterminated action", 0, 0)) } + { raise (Lexical_error("unterminated action", "", 0, 0)) } | '\010' - { line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num; + { incr_loc lexbuf 0; action lexbuf } | _ { action lexbuf } and skip_char = parse | '\\'? '\010' "'" - { line_start_pos := Lexing.lexeme_end lexbuf; - incr line_num } + { incr_loc lexbuf 1; + } | [^ '\\' '\''] "'" (* regular character *) (* one character and numeric escape sequences *) | '\\' _ "'" diff --git a/lex/lexgen.ml b/lex/lexgen.ml index a4d529bb..d891f28f 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -12,7 +12,7 @@ (* *) (***********************************************************************) -(* $Id: lexgen.ml,v 1.15 2003/02/24 10:59:19 maranget Exp $ *) +(* $Id: lexgen.ml,v 1.17 2004/03/23 16:57:24 maranget Exp $ *) (* Compiling a lexer definition *) @@ -155,7 +155,7 @@ let rec do_find_opt = function let opt1,all1 = do_find_opt e1 and opt2,all2 = do_find_opt e2 in StringSet.union - (stringset_delta opt1 opt2) + (StringSet.union opt1 opt2) (stringset_delta all1 all2), StringSet.union all1 all2 | Repetition e -> @@ -1002,7 +1002,8 @@ let apply_transitions gen r pri m ts = (* For a given nfa_state pos, refine char partition *) let rec split_env gen follow pos m s = function - | [] -> assert false + | [] -> (* Can occur ! because of non-matching regexp ([^'\000'-'\255']) *) + [] | (s1,st1) as p::rem -> let here = Cset.inter s s1 in if Cset.is_empty here then diff --git a/lex/main.ml b/lex/main.ml index 30fc4fbe..e87359fe 100644 --- a/lex/main.ml +++ b/lex/main.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: main.ml,v 1.18 2003/09/11 14:51:06 maranget Exp $ *) +(* $Id: main.ml,v 1.21 2004/04/29 11:12:49 maranget Exp $ *) (* The lexer generator. Command-line parsing. *) @@ -26,7 +26,7 @@ let usage = "usage: ocamlex [options] sourcefile" let specs = ["-ml", Arg.Set ml_automata, " Output code that does not use the Lexing module built-in automata interpreter"; - "-o", Arg.String (fun x -> source_name := Some x), + "-o", Arg.String (fun x -> output_name := Some x), " Set output file name to "; "-q", Arg.Set Common.quiet_mode, " Do not display informational messages"; ] @@ -55,6 +55,9 @@ let main () = let oc = open_out dest_name in let tr = Common.open_tracker dest_name oc in let lexbuf = Lexing.from_channel ic in + lexbuf.Lexing.lex_curr_p <- + {Lexing.pos_fname = source_name; Lexing.pos_lnum = 1; + Lexing.pos_bol = 0; Lexing.pos_cnum = 0}; try let def = Parser.lexer_definition Lexer.main lexbuf in let (entries, transitions) = Lexgen.make_dfa def.entrypoints in @@ -76,15 +79,22 @@ let main () = Common.close_tracker tr; Sys.remove dest_name; begin match exn with - Parsing.Parse_error -> + | Cset.Bad -> + let p = Lexing.lexeme_start_p lexbuf in + Printf.fprintf stderr + "File \"%s\", line %d, character %d: character set expected.\n" + p.Lexing.pos_fname p.Lexing.pos_lnum + (p.Lexing.pos_cnum - p.Lexing.pos_bol) + | Parsing.Parse_error -> + let p = Lexing.lexeme_start_p lexbuf in 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) -> + p.Lexing.pos_fname p.Lexing.pos_lnum + (p.Lexing.pos_cnum - p.Lexing.pos_bol) + | Lexer.Lexical_error(msg, file, line, col) -> Printf.fprintf stderr "File \"%s\", line %d, character %d: %s.\n" - source_name line col msg + file line col msg | Lexgen.Memory_overflow -> Printf.fprintf stderr "File \"%s\":\n Position memory overflow, too many bindings\n" diff --git a/lex/output.ml b/lex/output.ml index d18b0017..201e2c92 100644 --- a/lex/output.ml +++ b/lex/output.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: output.ml,v 1.24 2003/08/29 17:33:45 doligez Exp $ *) +(* $Id: output.ml,v 1.25 2004/02/12 17:29:04 maranget Exp $ *) (* Output the DFA tables and its entry points *) @@ -99,8 +99,8 @@ let output_entry sourcefile ic oc oci e = copy_chunk sourcefile ic oc oci loc true; fprintf oc "\n") e.auto_actions; - fprintf oc " | n -> lexbuf.Lexing.refill_buff lexbuf; \ - __ocaml_lex_%s_rec %alexbuf n\n\n" + fprintf oc " | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; \ + __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state\n\n" e.auto_name output_args e.auto_args (* Main output function *) diff --git a/lex/parser.mly b/lex/parser.mly index 3892872b..c3f3d473 100644 --- a/lex/parser.mly +++ b/lex/parser.mly @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: parser.mly,v 1.19 2003/08/13 13:36:03 doligez Exp $ */ +/* $Id: parser.mly,v 1.20 2004/04/29 11:12:49 maranget Exp $ */ /* The grammar for lexer definitions */ @@ -40,6 +40,10 @@ let rec remove_as = function | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2) | Repetition e -> Repetition (remove_as e) +let as_cset = function + | Characters s -> s + | _ -> raise Cset.Bad + %} %token Tident @@ -47,9 +51,10 @@ let rec remove_as = function %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 +%token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash Tlet Tas Tsharp %right Tas +%left Tsharp %left Tor %nonassoc CONCAT %nonassoc Tmaybe Tstar Tplus @@ -131,6 +136,12 @@ regexp: { Alternative(Epsilon, $1) } | regexp Tplus { Sequence(Repetition (remove_as $1), $1) } + | regexp Tsharp regexp + { + let s1 = as_cset $1 + and s2 = as_cset $3 in + Characters (Cset.diff s1 s2) + } | regexp Tor regexp { Alternative($1,$3) } | regexp regexp %prec CONCAT diff --git a/maccaml/.cvsignore b/maccaml/.cvsignore deleted file mode 100644 index efe28a12..00000000 --- a/maccaml/.cvsignore +++ /dev/null @@ -1,12 +0,0 @@ -stdlib -*.c.x -*.cp.x -*.xcoff -*.dbg -appliprims -appli -prims.c -Objective*Caml -OCaml.68k -OCaml.PPC -dummy_fragment diff --git a/maccaml/Makefile.Mac b/maccaml/Makefile.Mac deleted file mode 100644 index 85f938fb..00000000 --- a/maccaml/Makefile.Mac +++ /dev/null @@ -1,121 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id: 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 deleted file mode 100644 index b225a6e0..00000000 --- a/maccaml/Makefile.Mac.depend +++ /dev/null @@ -1,2032 +0,0 @@ -#*** Dependencies: Cut here *** -# These dependencies were produced at 20:33:24 on Tue, Aug 21, 2001 by MakeDepend - -:aboutbox.c.x Ä ¶ - :aboutbox.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:appleevents.c.x Ä ¶ - :appleevents.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:clipboard.c.x Ä ¶ - :clipboard.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:drag.c.x Ä ¶ - :drag.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:dummy_fragment.c.x Ä ¶ - :dummy_fragment.c - -:errors.c.x Ä ¶ - :errors.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:events.c.x Ä ¶ - :events.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:files.c.x Ä ¶ - :files.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:glue.c.x Ä ¶ - :glue.c ¶ - "{CIncludes}"CursorCtl.h ¶ - "{CIncludes}"fcntl.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdlib.h ¶ - :main.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:graph.c.x Ä ¶ - :graph.c ¶ - "{CIncludes}"memory.h ¶ - :main.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:lcontrols.c.x Ä ¶ - :lcontrols.c ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"ToolUtils.h ¶ - :main.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h ¶ - "{CIncludes}"CFURL.h - -:lib.c.x Ä ¶ - :lib.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:main.c.x Ä ¶ - :main.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:mcmemory.c.x Ä ¶ - :mcmemory.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:mcmisc.c.x Ä ¶ - :mcmisc.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:menus.c.x Ä ¶ - :menus.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:modalfilter.c.x Ä ¶ - :modalfilter.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:prefs.c.x Ä ¶ - :prefs.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:prims.c.x Ä ¶ - :prims.c - -:print.c.x Ä ¶ - :print.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:scroll.c.x Ä ¶ - :scroll.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - -:windows.c.x Ä ¶ - :windows.c ¶ - :main.h ¶ - "{CIncludes}"limits.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"stdio.h ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"AERegistry.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"ControlDefinitions.h ¶ - "{CIncludes}"Controls.h ¶ - "{CIncludes}"Devices.h ¶ - "{CIncludes}"Dialogs.h ¶ - "{CIncludes}"DiskInit.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"FixMath.h ¶ - "{CIncludes}"Folders.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Gestalt.h ¶ - "{CIncludes}"LowMem.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"Power.h ¶ - "{CIncludes}"Printing.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"QuickDraw.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"Scrap.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"SegLoad.h ¶ - "{CIncludes}"Sound.h ¶ - "{CIncludes}"StandardFile.h ¶ - "{CIncludes}"Strings.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"ToolUtils.h ¶ - ::byterun:rotatecursor.h ¶ - :ocamlconstants.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"AEInteraction.h ¶ - "{CIncludes}"Appearance.h ¶ - "{CIncludes}"CarbonEvents.h ¶ - "{CIncludes}"Lists.h ¶ - "{CIncludes}"MacHelp.h ¶ - "{CIncludes}"CFString.h ¶ - "{CIncludes}"TextEdit.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"NameRegistry.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"Multiprocessing.h ¶ - "{CIncludes}"DriverFamilyMatching.h ¶ - "{CIncludes}"Disks.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"ATSTypes.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CGContext.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"Balloons.h ¶ - "{CIncludes}"CFBase.h ¶ - "{CIncludes}"CFArray.h ¶ - "{CIncludes}"CFData.h ¶ - "{CIncludes}"CFDictionary.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"CFBundle.h ¶ - "{CIncludes}"CGBase.h ¶ - "{CIncludes}"CGAffineTransform.h ¶ - "{CIncludes}"CGColorSpace.h ¶ - "{CIncludes}"CGFont.h ¶ - "{CIncludes}"CGImage.h ¶ - "{CIncludes}"CGPDFDocument.h ¶ - "{CIncludes}"TypeSelect.h ¶ - "{CIncludes}"CFURL.h ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"CGGeometry.h ¶ - "{CIncludes}"CGDataProvider.h - diff --git a/maccaml/SHORTCUTS b/maccaml/SHORTCUTS deleted file mode 100644 index 144c7328..00000000 --- a/maccaml/SHORTCUTS +++ /dev/null @@ -1,9 +0,0 @@ -option-click a scrollbar's arrow -> scroll by one pixel - -Enter in the toplevel window -> go to bottom of window and append -a newline - -Drag & drop to the toplevel window -> go to bottom of window and -append the dragged text - -Command-period in the toplevel window -> interrupt O'Caml's computation diff --git a/maccaml/WASTE/.cvsignore b/maccaml/WASTE/.cvsignore deleted file mode 100644 index 652f7a04..00000000 --- a/maccaml/WASTE/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -WASTE*1.3*Distribution diff --git a/maccaml/WASTE/Makefile b/maccaml/WASTE/Makefile deleted file mode 100644 index 39e41c40..00000000 --- a/maccaml/WASTE/Makefile +++ /dev/null @@ -1,507 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id: Makefile,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 deleted file mode 100644 index fd8e5e1e..00000000 --- a/maccaml/WASTE/README +++ /dev/null @@ -1,5 +0,0 @@ -WASTE 1.3 is needed to build the O'Caml standalone application. - -Get WASTE 1.3 from -and unpack it in this directory (maccaml:WASTE:) to create the folder -"WASTE 1.3 Distribution". diff --git a/maccaml/aboutbox.c b/maccaml/aboutbox.c deleted file mode 100644 index 1d999807..00000000 --- a/maccaml/aboutbox.c +++ /dev/null @@ -1,125 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index ca775025..00000000 --- a/maccaml/appleevents.c +++ /dev/null @@ -1,147 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index 70c1ce2c..00000000 --- a/maccaml/appli.r +++ /dev/null @@ -1,808 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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/drag.c b/maccaml/drag.c deleted file mode 100644 index a148602f..00000000 --- a/maccaml/drag.c +++ /dev/null @@ -1,241 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index 2a924f1d..00000000 --- a/maccaml/dummy_fragment.c +++ /dev/null @@ -1 +0,0 @@ -/* This file intentionally left blank. */ diff --git a/maccaml/errors.c b/maccaml/errors.c deleted file mode 100644 index a3d98e3c..00000000 --- a/maccaml/errors.c +++ /dev/null @@ -1,114 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index fdb2d402..00000000 --- a/maccaml/events.c +++ /dev/null @@ -1,319 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index a2b9918c..00000000 --- a/maccaml/files.c +++ /dev/null @@ -1,427 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index efe66e80..00000000 --- a/maccaml/glue.c +++ /dev/null @@ -1,557 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index 38ce0953..00000000 --- a/maccaml/graph.c +++ /dev/null @@ -1,1179 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index c17e6b57..00000000 --- a/maccaml/lcontrols.c +++ /dev/null @@ -1,246 +0,0 @@ -/* - WASTE Demo Project: - Macintosh Controls with Long Values - - Copyright © 1993-1996 Marco Piovanelli - All Rights Reserved - - C port by John C. Daub -*/ - -/*************************************************************************** - This file is not subject to the O'Caml licence. - It is a slightly modified version of "LongControls.c" from - the WASTE Demo source (version 1.2). - ***************************************************************************/ -/* $Id: 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 deleted file mode 100644 index 79456ad7..00000000 --- a/maccaml/lib.c +++ /dev/null @@ -1,35 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index dd4294a3..00000000 --- a/maccaml/main.c +++ /dev/null @@ -1,125 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index 862d8fcc..00000000 --- a/maccaml/main.h +++ /dev/null @@ -1,264 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index 2ef0c2d8..00000000 --- a/maccaml/mcmemory.c +++ /dev/null @@ -1,31 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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/menus.c b/maccaml/menus.c deleted file mode 100644 index 56a7b1cd..00000000 --- a/maccaml/menus.c +++ /dev/null @@ -1,339 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index 5f190fe4..00000000 --- a/maccaml/modalfilter.c +++ /dev/null @@ -1,83 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index b5fa5aac..00000000 --- a/maccaml/ocaml.r +++ /dev/null @@ -1,479 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index 06db8b4c..00000000 --- a/maccaml/ocamlconstants.h +++ /dev/null @@ -1,187 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index 0947d201..00000000 --- a/maccaml/ocamlmkappli +++ /dev/null @@ -1,89 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Moscova, INRIA Rocquencourt # -# # -# Copyright 2000 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# $Id: ocamlmkappli,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 deleted file mode 100644 index 4a87ba59..00000000 --- a/maccaml/prefs.c +++ /dev/null @@ -1,127 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index abec3890..00000000 --- a/maccaml/prim_bigarray +++ /dev/null @@ -1,18 +0,0 @@ -bigarray_blit -bigarray_create -bigarray_dim -bigarray_fill -bigarray_get_1 -bigarray_get_2 -bigarray_get_3 -bigarray_get_generic -bigarray_init -bigarray_map_file -bigarray_num_dims -bigarray_reshape -bigarray_set_1 -bigarray_set_2 -bigarray_set_3 -bigarray_set_generic -bigarray_slice -bigarray_sub diff --git a/maccaml/prim_graph b/maccaml/prim_graph deleted file mode 100644 index 35c00284..00000000 --- a/maccaml/prim_graph +++ /dev/null @@ -1,41 +0,0 @@ -gr_blit_image -gr_clear_graph -gr_close_graph -gr_close_subwindow -gr_create_image -gr_current_x -gr_current_y -gr_display_mode -gr_draw_arc -gr_draw_arc_nat -gr_draw_char -gr_draw_image -gr_draw_rect -gr_draw_string -gr_dump_image -gr_fill_arc -gr_fill_arc_nat -gr_fill_poly -gr_fill_rect -gr_lineto -gr_make_image -gr_moveto -gr_open_graph -gr_open_subwindow -gr_plot -gr_point_color -gr_remember_mode -gr_set_color -gr_set_font -gr_set_line_width -gr_set_text_size -gr_set_window_title -gr_sigio_handler -gr_sigio_signal -gr_size_x -gr_size_y -gr_sound -gr_synchronize -gr_text_size -gr_wait_event -gr_window_id diff --git a/maccaml/prim_num b/maccaml/prim_num deleted file mode 100644 index 9a30b253..00000000 --- a/maccaml/prim_num +++ /dev/null @@ -1,28 +0,0 @@ -add_nat -blit_nat -compare_digits_nat -compare_nat -complement_nat -create_nat -decr_nat -div_digit_nat -div_nat -incr_nat -initialize_nat -is_digit_int -is_digit_normalized -is_digit_odd -is_digit_zero -land_digit_nat -lor_digit_nat -lxor_digit_nat -mult_digit_nat -mult_nat -nth_digit_nat -num_digits_nat -num_leading_zero_bits_in_digit -set_digit_nat -set_to_zero_nat -shift_left_nat -shift_right_nat -sub_nat diff --git a/maccaml/prim_str b/maccaml/prim_str deleted file mode 100644 index 00e31ec5..00000000 --- a/maccaml/prim_str +++ /dev/null @@ -1,8 +0,0 @@ -str_compile_regexp -str_string_match -str_string_partial_match -str_search_forward -str_search_backward -str_beginning_group -str_end_group -str_replacement_text diff --git a/maccaml/print.c b/maccaml/print.c deleted file mode 100644 index fbf0f0d3..00000000 --- a/maccaml/print.c +++ /dev/null @@ -1,131 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index 430d4d5f..00000000 --- a/maccaml/scroll.c +++ /dev/null @@ -1,325 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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 deleted file mode 100644 index c6eb3b61..00000000 --- a/maccaml/windows.c +++ /dev/null @@ -1,852 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: 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/ocamlc.m b/man/ocamlc.m index 2f25d54e..bc133e76 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -44,7 +44,8 @@ These executable files are then run by the bytecode interpreter The .BR ocamlc (1) command has a command-line interface similar to the one of -most C compilers. It accepts several types of arguments: +most C compilers. It accepts several types of arguments and processes them +sequentially: Arguments ending in .mli are taken to be source files for compilation unit interfaces. Interfaces specify the names exported by @@ -118,7 +119,7 @@ flag is set (see the description of .B \-custom below). -Arguments ending in .o or.a are assumed to be C object files and +Arguments ending in .o or .a are assumed to be C object files and libraries. They are passed to the C linker when linking in .B \-custom mode (see the description of diff --git a/man/ocamldoc.m b/man/ocamldoc.m new file mode 100644 index 00000000..fbffa749 --- /dev/null +++ b/man/ocamldoc.m @@ -0,0 +1,515 @@ +.TH OCAMLDOC 1 "February 6, 2004" "GNU/Linux" "User's Manual" + +.de Sh \" Subsection heading +.br +.if t .Sp +.ne 5 +.PP +\fB\\$1\fR +.PP +.. + +.SH NAME +ocamldoc \- The Objective Caml documentation generator + + +.SH SYNOPSIS +.B ocamldoc +[ +.B \-html +] +[ +.B \-latex +] +[ +.B \-texi +] +[ +.B \-man +] +[ +.B \-dot +] +[ +.BI \-g \ file +] +[ +.BI \-d \ dir +] +[ +.BI \-dump \ file +] +[ +.BI \-hide \ modules +] +[ +.B \-inv\-merge\-ml\-mli +] +[ +.B \-keep\-code +] +[ +.BI \-load \ file +] +[ +.BI \-m \ flags +] +[ +.BI \-o \ file +] +[ +.BI \-I \ directory +] +[ +.BI ... +] +.I filename ... + +.SH DESCRIPTION + +The Objective Caml documentation generator +.BR ocamldoc (1) +generates documentation from special comments embedded in source files. The +comments used by OCamldoc are of the form +.I (**...*) +and follow the format described in the +.IR "The Objective Caml user's manual" . + +OCamldoc can produce documentation in various formats: HTML, LaTeX, TeXinfo, +Unix man pages, and +.BR dot (1) +dependency graphs. Moreover, users can add their own +custom generators. + +In this manpage, we use the word +.IR element +to refer to any of the following parts of an OCaml source file: a type +declaration, a value, a module, an exception, a module type, a type +constructor, a record field, a class, a class type, a class method, a class +value or a class inheritance clause. + +.SH OPTIONS + +The following command-line options determine the format for the generated +documentation generated by +.BR ocamldoc (1). + +.Sh "Options for choosing the output format" + +.TP +.B \-html +Generate documentation in HTML default format. The generated HTML pages are +stored in the current directory, or in the directory specified with the +.B \-d +option. You can customize the style of the generated pages by editing the +generated +.I style.css +file, or by providing your own style sheet using option +.B \-css\-style +. The file +.I style.css +is not generated if it already exists. + +.TP +.B \-latex +Generate documentation in LaTeX default format. The generated LaTeX document +is saved in file +.IR ocamldoc.out , +or in the file specified with the +.B -o +option. The document uses the style file +.IR ocamldoc.sty . +This file is generated when using the +.B \-latex +option, if it does not already exist. You can change this file to customize +the style of your LaTeX documentation. + +.TP +.B \-texi +Generate documentation in TeXinfo default format. The generated LaTeX document +is saved in file +.IR ocamldoc.out , +or in the file specified with the +.B -o +option. + +.TP +.B \-man +Generate documentation as a set of Unix man pages. The generated pages are +stored in the current directory, or in the directory specified with the +.B \-d +option. + +.TP +.B \-dot +Generate a dependency graph for the toplevel modules, in a format suitable for +displaying and processing by dot. The +.IR dot (1) +tool is available from +.IR http://www.research.att.com/sw/tools/graphviz/ . +The textual representation of the graph is written to the file +.IR ocamldoc.out , +or to the file specified with the +.B -o +option. Use +.BI dot \ ocamldoc.out +to display it. + +.TP +.BI \-g \ file +Dynamically load the given file (which extension usually is .cmo or .cma), +which defines a custom documentation generator. This option is supported by the +.BR ocamldoc (1) +command, but not by its native-code version +.BR ocamldoc.opt . +If the given file is a simple one and does not exist in +the current directory, then ocamldoc looks for it in the custom +generators default directory. + +.TP +.BI \-customdir +Display the custom generators default directory. + +.TP +.BI \-i \ directory +Add the given directory to the path where to look for custom generators. + +.Sh "General options" + +.TP +.BI \-d \ dir +Generate files in directory +.IR dir , +rather than in the current directory. + +.TP +.BI \-dump \ file +Dump collected information into file. This information can be read with the +.B -load +option in a subsequent invocation of +.BR ocamldoc (1). + +.TP +.BI \-hide \ modules +Hide the given complete module names in the generated documentation. +.I modules +is a list of complete module names are separated by ',', without blanks. For +instance: +.IR Pervasives,M2.M3 . + +.TP +.B \-inv\-merge\-ml\-mli +Inverse implementations and interfaces when merging. All elements in +implementation files are kept, and the +.B \-m +option indicates which parts of the comments in interface files are merged with +the comments in implementation files. + +.TP +.B \-keep\-code +Always keep the source code for values, methods and instance variables, when +available. The source code is always kept when a .ml +file is given, but is by default discarded when a .mli +is given. This option allows to always keep the source code. + +.TP +.BI \-load \ file +Load information from +.IR file , +which has been produced by +.B ocamldoc +.BR \-dump . +Several +.B -load +options can be given. + +.TP +.BI \-m flags +Specify merge options between interfaces and implementations. +.I flags +can be one or several of the following characters: + +.B d +merge description + +.B a +merge @author + +.B v +merge @version + +.B l +merge @see + +.B s +merge @since + +.B o +merge @deprecated + +.B p +merge @param + +.B e +merge @raise + +.B r +merge @return + +.B A +merge everything + +.TP +.B \-no\-custom\-tags +Do not allow custom @-tags. + +.TP +.B \-no\-stop +Keep elements placed after the +.I (**/**) +special comment. + +.TP +.BI \-o \ file +Output the generated documentation to +.I file +instead of +.IR ocamldoc.out . +This option is meaningful only in conjunction with the +.BR \-latex , +.BR \-texi , +or +.B \-dot +options. + +.TP +.BI \-pp \ command +Pipe sources through preprocessor command. + +.TP +.B \-sort +Sort the list of top-level modules before generating the documentation. + +.TP +.B \-stars +Remove blank characters until the first asterisk ('*') in each line of comments. + +.TP +.BI \-t \ title +Use +.I title +as the title for the generated documentation. + +.TP +.BI \-intro \ file +Use content of +.I file +as ocamldoc text to use as introduction (HTML, \LaTeX and TeXinfo only). +For HTML, the file is used to create the whole "index.html" file. + +.TP +.B \-v +Verbose mode. Display progress information. + +.TP +.B \-warn-error +Treat warnings as errors. + +.Sh "Type-checking options" + +.BR ocamldoc (1) +calls the Objective Caml type-checker to obtain type informations. The +following options impact the type-checking phase. They have the same meaning +as for the +.BR ocamlc (1) +and +.BR ocamlopt (1) +commands. + +.TP +.BI \-I \ directory +Add directory to the list of directories search for compiled interface files +(.cmi files). + +.TP +.B \-nolabels +Ignore non-optional labels in types. + +.TP +.B \-rectypes + Allow arbitrary recursive types. (See the +.B \-rectypes +option to +.BR ocamlc (1).) + +.Sh "Options for generating HTML pages" + +The following options apply in conjunction with the +.B \-html +option: + +.TP +.B \-all-params +Display the complete list of parameters for functions and methods. + +.TP +.BI \-css-style \ filename +Use filename as the Cascading Style Sheet file. + +.TP +.B \-colorize-code +Colorize the OCaml code enclosed in [ ] and \\{[ ]\\}, using colors to emphasize +keywords, etc. If the code fragments are not syntactically correct, no color +is added. + +.TP +.B \-index-only +Generate only index files. + +.Sh "Options for generating LaTeX files" + +The following options apply in conjunction with the +.B \-latex +option: + +.TP +.B \-latex-value-prefix prefix +Give a prefix to use for the labels of the values in the generated LaTeX +document. The default prefix is the empty string. You can also use the options +.BR -latex-type-prefix , +.BR -latex-exception-prefix , +.BR -latex-module-prefix , +.BR -latex-module-type-prefix , +.BR -latex-class-prefix , +.BR -latex-class-type-prefix , +.B -latex-attribute-prefix +and +.BR -latex-method-prefix . + +These options are useful when you have, for example, a type and a value +with the same name. If you do not specify prefixes, LaTeX will complain about +multiply defined labels. + +.TP +.BI \-latextitle \ n,style +Associate style number +.I n +to the given LaTeX sectioning command style, e.g. section or subsection. +(LaTeX only.) This is useful when including the generated document in another +LaTeX document, at a given sectioning level. The default association is 1 for +section, 2 for subsection, 3 for subsubsection, 4 for paragraph and 5 for +subparagraph. + +.TP +.B \-noheader +Suppress header in generated documentation. + +.TP +.B \-notoc +Do not generate a table of contents. + +.TP +.B \-notrailer +Suppress trailer in generated documentation. + +.TP +.B \-sepfiles +Generate one .tex file per toplevel module, instead of the global +.I ocamldoc.out +file. + +.Sh "Options for generating TeXinfo files" + +The following options apply in conjunction with the +.B -texi +option: + +.TP +.B \-esc8 +Escape accented characters in Info files. + +.TP +.B +\-info-entry +Specify Info directory entry. + +.TP +.B \-info-section +Specify section of Info directory. + +.TP +.B \-noheader +Suppress header in generated documentation. + +.TP +.B \-noindex +Do not build index for Info files. + +.TP +.B \-notrailer +Suppress trailer in generated documentation. + +.Sh "Options for generating dot graphs" + +The following options apply in conjunction with the +.B \-dot +option: + +.TP +.BI \-dot-colors \ colors +Specify the colors to use in the generated dot code. When generating module +dependencies, +.BR ocamldoc (1) +uses different colors for modules, depending on the directories in which they +reside. When generating types dependencies, +.BR ocamldoc (1) +uses different colors for types, depending on the modules in which they are +defined. colors is a list of color names separated by ',', as in +.IR Red,Blue,Green . +The available colors are the ones supported by the +.BR dot (1) +tool. + +.TP +.B \-dot-include-all +Include all modules in the +.BR dot (1) +output, not only modules given on the command line or loaded with the +.B \-load +option. + +.TP +.B \-dot-reduce +Perform a transitive reduction of the dependency graph before outputting the +dot code. This can be useful if there are a lot of transitive dependencies +that clutter the graph. + +.TP +.B \-dot-types +Output dot code describing the type dependency graph instead of the module +dependency graph. + +.Sh "Options for generating man files" + +The following options apply in conjunction with the +.B \-man +option: + +.TP +.B \-man-mini +Generate man pages only for modules, module types, classes and class types, +instead of pages for all elements. + +.TP +.B \-man-suffix +Set the suffix used for generated man filenames. Default is 'o', like in +.IR List.o . + + +.SH SEE ALSO +.BR ocaml (1), +.BR ocamlc (1), +.BR ocamlopt (1). +.br +.IR "The Objective Caml user's manual", +chapter "The documentation generator". diff --git a/man/ocamlopt.m b/man/ocamlopt.m index 6ef10f81..da7c5997 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -44,7 +44,8 @@ The command has a command-line interface very close to that of .BR ocamlc (1). -It accepts the same types of arguments: +It accepts the same types of arguments and processes them +sequentially: Arguments ending in .mli are taken to be source files for compilation unit interfaces. Interfaces specify the names exported by diff --git a/man/ocamlprof.m b/man/ocamlprof.m index 0e1a6809..abc5301d 100644 --- a/man/ocamlprof.m +++ b/man/ocamlprof.m @@ -41,7 +41,7 @@ The default is the file ocamlprof.dump in the current directory. Specifies an additional string to be output with profiling information. By default, .B ocamlprof -will annotate progams with comments of the form +will annotate programs with comments of the form .BI (* \ n \ *) where .I n diff --git a/man/ocamlrun.m b/man/ocamlrun.m index 0fff44d7..7db888bd 100644 --- a/man/ocamlrun.m +++ b/man/ocamlrun.m @@ -21,7 +21,7 @@ command. The first non-option argument is taken to be the name of the file containing the executable bytecode. (That file is searched in the executable path as well as in the current directory.) The remaining -arguments are passed to the Caml Light program, in the string array +arguments are passed to the Objective Caml program, in the string array Sys.argv. Element 0 of this array is the name of the bytecode executable file; elements 1 to .I n @@ -62,6 +62,9 @@ A parameter specification is an option letter followed by an = sign, a decimal number, and an optional multiplier. There are seven options: .TP +.BR b \ (backtrace) +Print a stack backtrace in case of an uncaught exception. +.TP .BR s \ (minor_heap_size) Size of the minor heap. .TP @@ -104,6 +107,12 @@ Change of GC parameters. .TP .BR 64 Computation of major GC slice size. +.TP +.BR 128 +Calling of finalisation function. +.TP +.BR 256 +Startup messages. The multiplier is .B k diff --git a/ocamldoc/.cvsignore b/ocamldoc/.cvsignore index a9b23aa7..720ee641 100644 --- a/ocamldoc/.cvsignore +++ b/ocamldoc/.cvsignore @@ -11,3 +11,6 @@ odoc_text_parser.ml odoc_text_parser.mli stdlib_man *.output +test_stdlib +test_latex +test diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 8af1586b..d8c49f42 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -1,11 +1,11 @@ odoc.cmo: ../utils/clflags.cmo ../utils/config.cmi ../utils/misc.cmi \ - odoc_analyse.cmi odoc_args.cmi odoc_crc.cmo odoc_dot.cmo odoc_global.cmi \ - odoc_html.cmo odoc_info.cmi odoc_latex.cmo odoc_man.cmo odoc_messages.cmo \ - odoc_texi.cmo ../typing/typedtree.cmi + odoc_analyse.cmi odoc_args.cmi odoc_config.cmi odoc_dot.cmo \ + odoc_global.cmi odoc_html.cmo odoc_info.cmi odoc_latex.cmo odoc_man.cmo \ + odoc_messages.cmo odoc_texi.cmo ../typing/typedtree.cmi odoc.cmx: ../utils/clflags.cmx ../utils/config.cmx ../utils/misc.cmx \ - odoc_analyse.cmx odoc_args.cmx odoc_crc.cmx odoc_dot.cmx odoc_global.cmx \ - odoc_html.cmx odoc_info.cmx odoc_latex.cmx odoc_man.cmx odoc_messages.cmx \ - odoc_texi.cmx ../typing/typedtree.cmx + odoc_analyse.cmx odoc_args.cmx odoc_config.cmx odoc_dot.cmx \ + odoc_global.cmx odoc_html.cmx odoc_info.cmx odoc_latex.cmx odoc_man.cmx \ + odoc_messages.cmx odoc_texi.cmx ../typing/typedtree.cmx odoc_analyse.cmo: ../utils/ccomp.cmi ../utils/clflags.cmo ../utils/config.cmi \ ../typing/ctype.cmi ../typing/env.cmi ../typing/includemod.cmi \ ../parsing/lexer.cmi ../parsing/location.cmi ../utils/misc.cmi \ @@ -29,11 +29,11 @@ odoc_analyse.cmx: ../utils/ccomp.cmx ../utils/clflags.cmx ../utils/config.cmx \ ../typing/typedtree.cmx ../typing/typemod.cmx ../typing/typetexp.cmx \ ../utils/warnings.cmx odoc_analyse.cmi odoc_args.cmo: ../utils/clflags.cmo ../utils/config.cmi ../utils/misc.cmi \ - odoc_global.cmi odoc_messages.cmo odoc_module.cmo odoc_types.cmi \ - odoc_args.cmi + odoc_config.cmi odoc_global.cmi odoc_messages.cmo odoc_module.cmo \ + odoc_types.cmi odoc_args.cmi odoc_args.cmx: ../utils/clflags.cmx ../utils/config.cmx ../utils/misc.cmx \ - odoc_global.cmx odoc_messages.cmx odoc_module.cmx odoc_types.cmx \ - odoc_args.cmi + odoc_config.cmx odoc_global.cmx odoc_messages.cmx odoc_module.cmx \ + odoc_types.cmx odoc_args.cmi odoc_ast.cmo: ../parsing/asttypes.cmi ../parsing/location.cmi \ ../utils/misc.cmi odoc_args.cmi odoc_class.cmo odoc_env.cmi \ odoc_exception.cmo odoc_global.cmi odoc_messages.cmo odoc_module.cmo \ @@ -60,20 +60,22 @@ odoc_comments.cmx: odoc_comments_global.cmx odoc_global.cmx odoc_lexer.cmx \ odoc_types.cmx odoc_comments.cmi odoc_comments_global.cmo: odoc_comments_global.cmi odoc_comments_global.cmx: odoc_comments_global.cmi +odoc_config.cmo: ../utils/config.cmi odoc_config.cmi +odoc_config.cmx: ../utils/config.cmx odoc_config.cmi odoc_cross.cmo: odoc_class.cmo odoc_exception.cmo odoc_messages.cmo \ odoc_misc.cmi odoc_module.cmo odoc_name.cmi odoc_parameter.cmo \ - odoc_search.cmi odoc_type.cmo odoc_types.cmi odoc_value.cmo \ + odoc_scan.cmo odoc_search.cmi odoc_type.cmo odoc_types.cmi odoc_value.cmo \ odoc_cross.cmi odoc_cross.cmx: odoc_class.cmx odoc_exception.cmx odoc_messages.cmx \ odoc_misc.cmx odoc_module.cmx odoc_name.cmx odoc_parameter.cmx \ - odoc_search.cmx odoc_type.cmx odoc_types.cmx odoc_value.cmx \ + odoc_scan.cmx odoc_search.cmx odoc_type.cmx odoc_types.cmx odoc_value.cmx \ odoc_cross.cmi odoc_dag2html.cmo: odoc_info.cmi odoc_dag2html.cmi odoc_dag2html.cmx: odoc_info.cmx odoc_dag2html.cmi -odoc_dep.cmo: ../tools/depend.cmi odoc_misc.cmi odoc_module.cmo odoc_type.cmo \ - ../parsing/parsetree.cmi -odoc_dep.cmx: ../tools/depend.cmx odoc_misc.cmx odoc_module.cmx odoc_type.cmx \ - ../parsing/parsetree.cmi +odoc_dep.cmo: ../tools/depend.cmi odoc_module.cmo odoc_print.cmi \ + odoc_type.cmo ../parsing/parsetree.cmi +odoc_dep.cmx: ../tools/depend.cmx odoc_module.cmx odoc_print.cmx \ + odoc_type.cmx ../parsing/parsetree.cmi odoc_dot.cmo: odoc_info.cmi odoc_dot.cmx: odoc_info.cmx odoc_env.cmo: ../typing/btype.cmi odoc_name.cmi ../typing/path.cmi \ @@ -90,15 +92,17 @@ odoc_html.cmo: odoc_dag2html.cmi odoc_info.cmi odoc_messages.cmo \ odoc_ocamlhtml.cmo odoc_text.cmi odoc_html.cmx: odoc_dag2html.cmx odoc_info.cmx odoc_messages.cmx \ odoc_ocamlhtml.cmx odoc_text.cmx -odoc_info.cmo: odoc_analyse.cmi odoc_args.cmi odoc_class.cmo odoc_dep.cmo \ - odoc_exception.cmo odoc_global.cmi odoc_messages.cmo odoc_misc.cmi \ - odoc_module.cmo odoc_name.cmi odoc_parameter.cmo odoc_scan.cmo \ - odoc_search.cmi odoc_str.cmi odoc_type.cmo odoc_types.cmi odoc_value.cmo \ +odoc_info.cmo: odoc_analyse.cmi odoc_args.cmi odoc_class.cmo \ + odoc_comments.cmi odoc_dep.cmo odoc_exception.cmo odoc_global.cmi \ + odoc_messages.cmo odoc_misc.cmi odoc_module.cmo odoc_name.cmi \ + odoc_parameter.cmo odoc_print.cmi odoc_scan.cmo odoc_search.cmi \ + odoc_str.cmi odoc_text.cmi odoc_type.cmo odoc_types.cmi odoc_value.cmo \ ../typing/printtyp.cmi odoc_info.cmi -odoc_info.cmx: odoc_analyse.cmx odoc_args.cmx odoc_class.cmx odoc_dep.cmx \ - odoc_exception.cmx odoc_global.cmx odoc_messages.cmx odoc_misc.cmx \ - odoc_module.cmx odoc_name.cmx odoc_parameter.cmx odoc_scan.cmx \ - odoc_search.cmx odoc_str.cmx odoc_type.cmx odoc_types.cmx odoc_value.cmx \ +odoc_info.cmx: odoc_analyse.cmx odoc_args.cmx odoc_class.cmx \ + odoc_comments.cmx odoc_dep.cmx odoc_exception.cmx odoc_global.cmx \ + odoc_messages.cmx odoc_misc.cmx odoc_module.cmx odoc_name.cmx \ + odoc_parameter.cmx odoc_print.cmx odoc_scan.cmx odoc_search.cmx \ + odoc_str.cmx odoc_text.cmx odoc_type.cmx odoc_types.cmx odoc_value.cmx \ ../typing/printtyp.cmx odoc_info.cmi odoc_latex.cmo: odoc_info.cmi odoc_latex_style.cmo odoc_messages.cmo \ odoc_to_text.cmo @@ -108,8 +112,10 @@ odoc_lexer.cmo: odoc_args.cmi odoc_comments_global.cmi odoc_messages.cmo \ odoc_parser.cmi odoc_lexer.cmx: odoc_args.cmx odoc_comments_global.cmx odoc_messages.cmx \ odoc_parser.cmx -odoc_man.cmo: odoc_info.cmi odoc_messages.cmo odoc_misc.cmi -odoc_man.cmx: odoc_info.cmx odoc_messages.cmx odoc_misc.cmx +odoc_man.cmo: odoc_info.cmi odoc_messages.cmo odoc_misc.cmi odoc_print.cmi \ + odoc_str.cmi +odoc_man.cmx: odoc_info.cmx odoc_messages.cmx odoc_misc.cmx odoc_print.cmx \ + odoc_str.cmx odoc_merge.cmo: odoc_args.cmi odoc_class.cmo odoc_exception.cmo \ odoc_messages.cmo odoc_module.cmo odoc_name.cmi odoc_parameter.cmo \ odoc_type.cmo odoc_types.cmi odoc_value.cmo odoc_merge.cmi @@ -120,18 +126,14 @@ odoc_messages.cmo: ../utils/config.cmi odoc_global.cmi odoc_messages.cmx: ../utils/config.cmx odoc_global.cmx odoc_misc.cmo: ../typing/btype.cmi ../typing/ctype.cmi ../typing/ident.cmi \ ../parsing/longident.cmi odoc_messages.cmo odoc_types.cmi \ - ../typing/path.cmi ../typing/printtyp.cmi ../typing/types.cmi \ - odoc_misc.cmi + ../typing/path.cmi ../typing/types.cmi odoc_misc.cmi odoc_misc.cmx: ../typing/btype.cmx ../typing/ctype.cmx ../typing/ident.cmx \ ../parsing/longident.cmx odoc_messages.cmx odoc_types.cmx \ - ../typing/path.cmx ../typing/printtyp.cmx ../typing/types.cmx \ - odoc_misc.cmi + ../typing/path.cmx ../typing/types.cmx odoc_misc.cmi odoc_module.cmo: odoc_class.cmo odoc_exception.cmo odoc_name.cmi \ - odoc_parameter.cmo odoc_type.cmo odoc_types.cmi odoc_value.cmo \ - ../typing/types.cmi + odoc_type.cmo odoc_types.cmi odoc_value.cmo ../typing/types.cmi odoc_module.cmx: odoc_class.cmx odoc_exception.cmx odoc_name.cmx \ - odoc_parameter.cmx odoc_type.cmx odoc_types.cmx odoc_value.cmx \ - ../typing/types.cmx + odoc_type.cmx odoc_types.cmx odoc_value.cmx ../typing/types.cmx odoc_name.cmo: ../typing/ident.cmi ../parsing/longident.cmi \ ../typing/path.cmi odoc_name.cmi odoc_name.cmx: ../typing/ident.cmx ../parsing/longident.cmx \ @@ -148,6 +150,8 @@ odoc_parameter.cmo: odoc_types.cmi ../typing/types.cmi odoc_parameter.cmx: odoc_types.cmx ../typing/types.cmx odoc_parser.cmo: odoc_comments_global.cmi odoc_types.cmi odoc_parser.cmi odoc_parser.cmx: odoc_comments_global.cmx odoc_types.cmx odoc_parser.cmi +odoc_print.cmo: ../typing/printtyp.cmi ../typing/types.cmi odoc_print.cmi +odoc_print.cmx: ../typing/printtyp.cmx ../typing/types.cmx odoc_print.cmi odoc_scan.cmo: odoc_class.cmo odoc_exception.cmo odoc_module.cmo \ odoc_type.cmo odoc_types.cmi odoc_value.cmo odoc_scan.cmx: odoc_class.cmx odoc_exception.cmx odoc_module.cmx \ @@ -164,28 +168,34 @@ odoc_sig.cmo: ../parsing/asttypes.cmi ../typing/btype.cmi \ ../parsing/location.cmi ../utils/misc.cmi odoc_args.cmi odoc_class.cmo \ odoc_env.cmi odoc_exception.cmo odoc_global.cmi odoc_merge.cmi \ odoc_messages.cmo odoc_misc.cmi odoc_module.cmo odoc_name.cmi \ - odoc_parameter.cmo odoc_type.cmo odoc_types.cmi odoc_value.cmo \ - ../parsing/parsetree.cmi ../typing/path.cmi ../typing/typedtree.cmi \ - ../typing/types.cmi odoc_sig.cmi + odoc_parameter.cmo odoc_print.cmi odoc_type.cmo odoc_types.cmi \ + odoc_value.cmo ../parsing/parsetree.cmi ../typing/path.cmi \ + ../typing/typedtree.cmi ../typing/types.cmi odoc_sig.cmi odoc_sig.cmx: ../parsing/asttypes.cmi ../typing/btype.cmx \ ../parsing/location.cmx ../utils/misc.cmx odoc_args.cmx odoc_class.cmx \ odoc_env.cmx odoc_exception.cmx odoc_global.cmx odoc_merge.cmx \ odoc_messages.cmx odoc_misc.cmx odoc_module.cmx odoc_name.cmx \ - odoc_parameter.cmx odoc_type.cmx odoc_types.cmx odoc_value.cmx \ - ../parsing/parsetree.cmi ../typing/path.cmx ../typing/typedtree.cmx \ - ../typing/types.cmx odoc_sig.cmi + odoc_parameter.cmx odoc_print.cmx odoc_type.cmx odoc_types.cmx \ + odoc_value.cmx ../parsing/parsetree.cmi ../typing/path.cmx \ + ../typing/typedtree.cmx ../typing/types.cmx odoc_sig.cmi odoc_str.cmo: odoc_exception.cmo odoc_messages.cmo odoc_misc.cmi \ - odoc_name.cmi odoc_type.cmo odoc_value.cmo odoc_str.cmi + odoc_name.cmi odoc_print.cmi odoc_type.cmo odoc_value.cmo \ + ../typing/printtyp.cmi ../typing/types.cmi odoc_str.cmi odoc_str.cmx: odoc_exception.cmx odoc_messages.cmx odoc_misc.cmx \ - odoc_name.cmx odoc_type.cmx odoc_value.cmx odoc_str.cmi + odoc_name.cmx odoc_print.cmx odoc_type.cmx odoc_value.cmx \ + ../typing/printtyp.cmx ../typing/types.cmx odoc_str.cmi +odoc_test.cmo: odoc_info.cmi +odoc_test.cmx: odoc_info.cmx odoc_texi.cmo: odoc_info.cmi odoc_messages.cmo odoc_to_text.cmo odoc_texi.cmx: odoc_info.cmx odoc_messages.cmx odoc_to_text.cmx -odoc_text.cmo: odoc_text_lexer.cmo odoc_text_parser.cmi odoc_text.cmi -odoc_text.cmx: odoc_text_lexer.cmx odoc_text_parser.cmx odoc_text.cmi +odoc_text.cmo: odoc_text_lexer.cmo odoc_text_parser.cmi odoc_types.cmi \ + odoc_text.cmi +odoc_text.cmx: odoc_text_lexer.cmx odoc_text_parser.cmx odoc_types.cmx \ + odoc_text.cmi odoc_text_lexer.cmo: odoc_text_parser.cmi odoc_text_lexer.cmx: odoc_text_parser.cmx -odoc_text_parser.cmo: odoc_types.cmi odoc_text_parser.cmi -odoc_text_parser.cmx: odoc_types.cmx odoc_text_parser.cmi +odoc_text_parser.cmo: odoc_misc.cmi odoc_types.cmi odoc_text_parser.cmi +odoc_text_parser.cmx: odoc_misc.cmx odoc_types.cmx odoc_text_parser.cmi odoc_to_text.cmo: odoc_info.cmi odoc_messages.cmo odoc_to_text.cmx: odoc_info.cmx odoc_messages.cmx odoc_type.cmo: odoc_name.cmi odoc_types.cmi ../typing/types.cmi @@ -213,10 +223,12 @@ odoc_misc.cmi: ../parsing/longident.cmi odoc_types.cmi ../typing/types.cmi odoc_name.cmi: ../typing/ident.cmi ../parsing/longident.cmi \ ../typing/path.cmi odoc_parser.cmi: odoc_types.cmi +odoc_print.cmi: ../typing/types.cmi odoc_search.cmi: odoc_class.cmo odoc_exception.cmo odoc_module.cmo \ odoc_type.cmo odoc_types.cmi odoc_value.cmo odoc_sig.cmi: odoc_class.cmo odoc_env.cmi odoc_module.cmo odoc_name.cmi \ odoc_type.cmo odoc_types.cmi ../parsing/parsetree.cmi ../typing/types.cmi -odoc_str.cmi: odoc_exception.cmo odoc_type.cmo odoc_value.cmo +odoc_str.cmi: odoc_exception.cmo odoc_type.cmo odoc_value.cmo \ + ../typing/types.cmi odoc_text.cmi: odoc_types.cmi odoc_text_parser.cmi: odoc_types.cmi diff --git a/ocamldoc/Changes.txt b/ocamldoc/Changes.txt index 78baab8e..e4b6bfe5 100644 --- a/ocamldoc/Changes.txt +++ b/ocamldoc/Changes.txt @@ -1,3 +1,74 @@ +TODO: + - need to fix display of type parameters for inherited classes/class types + - latex: types variant polymorphes dépassent de la page quand ils sont trop longs + - utilisation nouvelles infos de Xavier: "début de rec", etc. + +===== +Release 3.08: + - fix: method parameters names in signature are now retrieved correctly + (fix of Odoc_value.parameter_list_from_arrows to handle Tpoly for methods) + - ajout à la doc de Module_list et Index_list (utilisé dans le html seulement) + - ajout à la doc: fichier de l'option -intro utilisé pour l'index en html + - fix: create a Module_with instead of a Module_alias when we encounter + module A : Foo in a signature + - latex: style latex pour indenter dans les module kind et les class kind + - latex: il manque la génération des paramètres de classe + - parse des {!modules: } et {!indexlist} + - gestion des Module_list et Index_list + - no need to Dynlink.add_available_units any more + - generate html from module_kind rather than from module_type + + same for classes and class types + - add the kind to module parameters (the way the parameter was build in the parsetree) + - fix: the generated ocamldoc.sty is more robust for paragraphs in + ocamldocdescription environment + - fix: when generating separated files in latex, generate them in + the same directory than the main file, (the one specified by -o) + - mod: one section per to module in latex output + improve latex output + - mod: odoc_latex: use buffers instead of string concatenation + - add: new ocamldoc man page, thanks to Samuel Mimram + - fix: useless parenthesis around agruments of arguments of a type constructor in + type definitions, and aournd arguments of exceptions in exception definitions. + - fix: blank lines in verbatim, latex, code pre, code and ele ref modes + are now accepted + - fix: html generator: included module names were displayed with their simple + name rather than their fully qualified name + - fix: use a formatter from a buffer rather Format.str_formatter in + Odoc_mist.sting_of_module_type, to avoid too much blanks + - new module odoc_print, will work when Format.pp_print_flush is fixed + - odoc_html: use buffers instead of string concatenation + - odoc_man: use buffers instead of string concatenation + - odoc_cross.ml: use hash tables modified on the fly to resolve + (module | module type | exception) name aliases + - odoc_html: replace some calls to Str. by specific functions on strings + - odoc_cross.ml: use a Map to associate a complete name to + the known elements with this name, instead of searching each time + through the whole list of modules -> a gain of more than 90% in speed + for cross-referencing (Odoc_cross.associate) + - fix: Odoc_name.cut printed a '(' instead of a '.' + - add: new option -customdir + - add: new option -i (to add a path to the directory where + to look for custom generators) + - add: add odoc_config.ml{,i} + - add: keep_code in Odoc_info.Args interface + - add: m_code_intf and m_code fields for modules, fit when the + Odoc_args.keep_code option is set, and fit for all modules, not + only toplevel ones + - fix: bug preventing to get the code in a .mli + - fix: missing spaces after carriage return in types (Odoc_misc.string_of_type_expr) + - fixes: some bugs in the text parser + ( ]} meaning end of code and somehting else instead of end of precode) + - add: in Odoc_info: text_of_string, text_string_of_text, info_of_string + - fix: better output of titles in html (use more the style) + - add: -intro option to use a file content as ocamldoc comment to use as + introduction for LaTeX document and HTML index page + - add: the HTML generator generates the code of the module if available + - add: field m_code for modules, to keep the code of top modules + - fix: display "include Foo" instead of "include module Foo" in Latex, Man, Texi + - fix: not display comments associated to include directives + - fix: bad display of type parameters for class and class types + +====== + Release 3.05 : - added link tags in html header to reference sections and subsections in each page (for browser which handle those tags) @@ -81,4 +152,4 @@ Rep-release 2 : their navigation bar (for example, mozilla 0.9.5 is compliant) - '{bone}' doesn't work any more ; a space is required as in '{b one}'. Same for {e, {i, and some others marks. Check the manual -- bug fixes \ No newline at end of file +- bug fixes diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 6c182faf..610064b1 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -9,7 +9,7 @@ #(* *) #(***********************************************************************) -# $Id: Makefile,v 1.43 2003/09/29 14:05:01 xleroy Exp $ +# $Id: Makefile,v 1.55 2004/04/23 14:10:51 guesdon Exp $ include ../config/Makefile @@ -23,7 +23,6 @@ OCAMLLEX = $(CAMLRUN) ../boot/ocamllex OCAMLYACC= ../boot/ocamlyacc OCAMLLIB = $(LIBDIR) OCAMLBIN = $(BINDIR) -EXTRAC_CRC = $(CAMLRUN) ../otherlibs/dynlink/extract_crc OCAMLPP=-pp './remove_DEBUG' @@ -39,12 +38,16 @@ OCAMLDOC_LIBCMI=odoc_info.cmi OCAMLDOC_LIBCMXA=odoc_info.cmxa OCAMLDOC_LIBA=odoc_info.a INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc +INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom INSTALL_BINDIR=$(OCAMLBIN) INSTALL_MANODIR=$(MANDIR)/man3 INSTALL_MLIS=odoc_info.mli INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) +ODOC_TEST=odoc_test.cmo + + # Compilation ############# OCAMLSRCDIR=.. @@ -60,6 +63,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ -I $(OCAMLSRCDIR)/otherlibs/str \ -I $(OCAMLSRCDIR)/otherlibs/dynlink \ -I $(OCAMLSRCDIR)/otherlibs/unix \ + -I $(OCAMLSRCDIR)/otherlibs/num \ -I $(OCAMLSRCDIR)/otherlibs/graph INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) @@ -67,7 +71,8 @@ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) COMPFLAGS=$(INCLUDES) -warn-error A LINKFLAGS=$(INCLUDES) -CMOFILES= odoc_global.cmo\ +CMOFILES= odoc_config.cmo \ + odoc_global.cmo\ odoc_messages.cmo\ odoc_types.cmo\ odoc_misc.cmo\ @@ -81,6 +86,7 @@ CMOFILES= odoc_global.cmo\ odoc_exception.cmo\ odoc_class.cmo\ odoc_module.cmo\ + odoc_print.cmo \ odoc_str.cmo\ odoc_args.cmo\ odoc_comments_global.cmo\ @@ -95,10 +101,10 @@ CMOFILES= odoc_global.cmo\ odoc_control.cmo\ odoc_inherit.cmo\ odoc_search.cmo\ + odoc_scan.cmo\ odoc_cross.cmo\ odoc_dep.cmo\ odoc_analyse.cmo\ - odoc_scan.cmo\ odoc_info.cmo @@ -179,10 +185,11 @@ STDLIB_MLIS=../stdlib/*.mli \ ../otherlibs/unix/unix.mli \ ../otherlibs/str/str.mli \ ../otherlibs/bigarray/bigarray.mli \ + ../otherlibs/num/num.mli all: exe lib manpages exe: $(OCAMLDOC) -lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) +lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST) opt.opt: exeopt libopt exeopt: $(OCAMLDOC_OPT) @@ -190,8 +197,8 @@ libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) debug: make OCAMLPP="" -$(OCAMLDOC): $(EXECMOFILES) odoc_crc.cmo odoc.cmo - $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc_crc.cmo odoc.cmo +$(OCAMLDOC): $(EXECMOFILES) odoc.cmo + $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc.cmo $(OCAMLDOC_OPT): $(EXECMXFILES) odoc_opt.cmx $(OCAMLOPT) -o $@ unix.cmxa str.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) odoc_opt.cmx @@ -200,35 +207,7 @@ $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES) -manpages: stdlib_man/Pervasives.o - -odoc_crc.ml: $(CMIFILES) - $(EXTRAC_CRC) $(INCLUDES) \ - Arg Array Buffer Callback Char Digest Dynlink \ - Filename Format Gc Genlex Hashtbl \ - Lazy Lexing List Map Marshal Nativeint \ - Obj CamlinternalOO Outcometree Parsing Pervasives Printexc \ - Printf Profiling Queue Random \ - Set Sort Stack Std_exit Str Stream \ - String Sys Topdirs Toploop Unix Weak \ - Printast Ident Tbl Misc Config Clflags Warnings Ccomp \ - Linenum Location Longident Syntaxerr Parser Lexer Parse \ - Types Path Btype Predef Datarepr Subst Env Ctype Primitive \ - Oprint Printtyp Includecore Typetexp Parmatch Typedtree Typecore \ - Includeclass Typedecl Typeclass Mtype Includemod Typemod \ - Lambda Typeopt Printlambda Switch Matching Translobj Translcore \ - Bytesections Runtimedef Symtable Opcodes Bytelink Bytelibrarian \ - Translclass Errors Main_args Asttypes Depend \ - Odoc_global Odoc_args Odoc_info Odoc_messages Odoc_types \ - Odoc_misc Odoc_text_parser Odoc_text_lexer \ - Odoc_text Odoc_comments_global Odoc_parser \ - Odoc_lexer Odoc_comments Odoc_name Odoc_parameter \ - Odoc_value Odoc_type Odoc_exception Odoc_class \ - Odoc_module Odoc_str Odoc_args Odoc_env \ - Odoc_sig Odoc_ast Odoc_control Odoc_inherit \ - Odoc_search Odoc_cross Odoc_merge Odoc_analyse \ - Odoc_dag2html Odoc_ocamlhtml Odoc_html Odoc_to_text \ - Odoc_latex_style Odoc_latex Odoc_man Odoc_texi Odoc_scan > $@ +manpages: stdlib_man/Pervasives.3o # Parsers and lexers dependencies : ################################### @@ -275,8 +254,9 @@ odoc_see_lexer.ml: odoc_see_lexer.mll install: dummy if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi + if test -d $(INSTALL_CUSTOMDIR); then : ; else $(MKDIR) $(INSTALL_CUSTOMDIR); fi $(CP) $(OCAMLDOC)$(EXE) $(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE) - $(CP) ocamldoc.hva *.cmi $(GENERATORS) $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR) + $(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR) $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) if test -d $(INSTALL_MANODIR); then : ; else $(MKDIR) $(INSTALL_MANODIR); fi $(CP) stdlib_man/* $(INSTALL_MANODIR) @@ -299,7 +279,8 @@ test: dummy test_stdlib: dummy $(MKDIR) $@ - $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/stdlib.odoc ../stdlib/*.mli \ + $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/stdlib.odoc -keep-code \ + ../stdlib/pervasives.ml ../stdlib/*.mli \ ../otherlibs/unix/unix.mli \ ../otherlibs/str/str.mli @@ -311,6 +292,15 @@ test_latex: dummy $(MKDIR) $@ $(OCAMLDOC_RUN) -latex -sort -o $@/test.tex -d $@ $(INCLUDES) odoc*.ml odoc*.mli ../stdlib/*.mli ../otherlibs/unix/unix.mli +test_latex_simple: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -latex -sort -o $@/test.tex -d $@ $(INCLUDES) \ + -latextitle 6,subsection -latextitle 7,subsubection \ + ../stdlib/hashtbl.mli \ + ../stdlib/arg.mli \ + ../otherlibs/unix/unix.mli \ + ../stdlib/map.mli + test_man: dummy $(MKDIR) $@ $(OCAMLDOC_RUN) -man -sort -d $@ $(INCLUDES) odoc*.ml odoc*.mli @@ -319,12 +309,20 @@ test_texi: dummy $(MKDIR) $@ $(OCAMLDOC_RUN) -texi -sort -d $@ $(INCLUDES) odoc*.ml odoc*.mli -stdlib_man/Pervasives.o: $(STDLIB_MLIS) +stdlib_man/Pervasives.3o: $(STDLIB_MLIS) $(MKDIR) stdlib_man $(OCAMLDOC_RUN) -man -d stdlib_man $(INCLUDES) \ -t "OCaml library" -man-mini -man-suffix 3o \ $(STDLIB_MLIS) +autotest_stdlib: dummy + $(MKDIR) $@ + $(OCAMLDOC_RUN) -g autotest/odoc_test.cmo\ + $(INCLUDES) -keep-code \ + ../stdlib/pervasives.ml ../stdlib/*.mli \ + ../otherlibs/unix/unix.mli \ + ../otherlibs/str/str.mli + # backup, clean and depend : ############################ @@ -333,7 +331,7 @@ clean:: dummy @rm -f $(OCAMLDOC)$(EXE) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.a *.o @rm -f odoc_parser.output odoc_text_parser.output @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml - @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli odoc_crc.ml + @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli @rm -rf stdlib_man depend:: diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index ed7f2b2c..d1b08749 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -9,7 +9,7 @@ #(* *) #(***********************************************************************) -# $Id: Makefile.nt,v 1.19 2003/08/29 12:15:41 xleroy Exp $ +# $Id: Makefile.nt,v 1.25 2004/04/23 14:10:51 guesdon Exp $ include ../config/Makefile @@ -21,7 +21,6 @@ OCAMLYACC=../boot/ocamlyacc OCAMLLIB = $(LIBDIR) OCAMLBIN = $(BINDIR) -EXTRAC_CRC = $(CAMLRUN) ../otherlibs/dynlink/extract_crc OCAMLPP=-pp "grep -v DEBUG" @@ -37,6 +36,7 @@ OCAMLDOC_LIBCMI=odoc_info.cmi OCAMLDOC_LIBCMXA=odoc_info.cmxa OCAMLDOC_LIBA=odoc_info.$(A) INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc +INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom INSTALL_BINDIR=$(OCAMLBIN) INSTALL_MLIS=odoc_info.mli @@ -65,7 +65,8 @@ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) COMPFLAGS=$(INCLUDES) LINKFLAGS=$(INCLUDES) -CMOFILES= odoc_global.cmo\ +CMOFILES= odoc_config.cmo \ + odoc_global.cmo\ odoc_messages.cmo\ odoc_types.cmo\ odoc_misc.cmo\ @@ -79,6 +80,7 @@ CMOFILES= odoc_global.cmo\ odoc_exception.cmo\ odoc_class.cmo\ odoc_module.cmo\ + odoc_print.cmo \ odoc_str.cmo\ odoc_args.cmo\ odoc_comments_global.cmo\ @@ -93,10 +95,10 @@ CMOFILES= odoc_global.cmo\ odoc_control.cmo\ odoc_inherit.cmo\ odoc_search.cmo\ + odoc_scan.cmo\ odoc_cross.cmo\ odoc_dep.cmo\ odoc_analyse.cmo\ - odoc_scan.cmo\ odoc_info.cmo @@ -184,8 +186,8 @@ libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) debug: make OCAMLPP="" -$(OCAMLDOC): $(EXECMOFILES) odoc_crc.cmo odoc.cmo - $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc_crc.cmo odoc.cmo +$(OCAMLDOC): $(EXECMOFILES) odoc.cmo + $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc.cmo $(OCAMLDOC_OPT): $(EXECMXFILES) odoc_opt.cmx $(OCAMLOPT) -o $@ unix.cmxa str.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) odoc_opt.cmx @@ -194,81 +196,6 @@ $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES) -odoc_crc.ml: $(CMIFILES) - $(EXTRAC_CRC) $(INCLUDES)\ - Arg Arith_status Array Big_int Buffer Callback Char Digest Dynlink \ - Filename Format Gc Genlex Hashtbl \ - Lazy Lexing List Map Marshal Nat Nativeint\ - Num Obj CamlinternalOO Outcometree Parsing Pervasives Printexc\ - Printf Profiling Queue Random Ratio\ - Set Sort Stack Std_exit Str Stream\ - String Sys Topdirs Toploop Unix Weak\ - Printast \ - Ident \ - Tbl \ - Misc \ - Config \ - Clflags \ - Warnings \ - Ccomp \ - Linenum\ - Location\ - Longident \ - Syntaxerr \ - Parser \ - Lexer \ - Parse \ - Types \ - Path \ - Btype \ - Predef \ - Datarepr \ - Subst \ - Env \ - Ctype \ - Primitive \ - Oprint \ - Printtyp \ - Includecore \ - Typetexp \ - Parmatch \ - Typedtree \ - Typecore \ - Includeclass \ - Typedecl \ - Typeclass \ - Mtype \ - Includemod \ - Typemod \ - Lambda \ - Typeopt \ - Printlambda \ - Switch \ - Matching \ - Translobj \ - Translcore \ - Bytesections \ - Runtimedef \ - Symtable \ - Opcodes \ - Bytelink \ - Bytelibrarian \ - Translclass \ - Errors \ - Main_args \ - Asttypes \ - Depend \ - Odoc_global Odoc_args Odoc_info Odoc_messages Odoc_types\ - Odoc_misc Odoc_text_parser Odoc_text_lexer\ - Odoc_text Odoc_comments_global Odoc_parser\ - Odoc_lexer Odoc_comments Odoc_name Odoc_parameter\ - Odoc_value Odoc_type Odoc_exception Odoc_class\ - Odoc_module Odoc_str Odoc_args Odoc_env\ - Odoc_sig Odoc_ast Odoc_control Odoc_inherit\ - Odoc_search Odoc_cross Odoc_merge Odoc_analyse\ - Odoc_dag2html Odoc_ocamlhtml Odoc_html Odoc_to_text \ - Odoc_latex_style Odoc_latex Odoc_man Odoc_texi Odoc_scan > $@ - # generic rules : ################# @@ -307,7 +234,7 @@ install: dummy $(MKDIR) -p $(INSTALL_BINDIR) $(MKDIR) -p $(INSTALL_LIBDIR) $(CP) $(OCAMLDOC) $(INSTALL_BINDIR)/$(OCAMLDOC).exe - $(CP) ocamldoc.hva *.cmi $(GENERATORS) $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR) + $(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR) $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) installopt: @@ -329,7 +256,7 @@ clean:: dummy @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O) @rm -f odoc_parser.output odoc_text_parser.output @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml - @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli odoc_crc.ml + @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli depend:: rm -f .depend diff --git a/ocamldoc/ocamldoc.hva b/ocamldoc/ocamldoc.hva index c78417f3..454cee9e 100644 --- a/ocamldoc/ocamldoc.hva +++ b/ocamldoc/ocamldoc.hva @@ -7,4 +7,13 @@ \newcommand\textasciicircum{\^{}} \newcommand\sharp{#} - +\let\ocamldocvspace\vspace +\newenvironment{ocamldocindent}{\list{}{}\item\relax}{\endlist} +\newenvironment{ocamldocsigend} + {\noindent\quad\texttt{sig}\ocamldocindent} + {\endocamldocindent\vskip -\lastskip + \noindent\quad\texttt{end}\medskip} +\newenvironment{ocamldocobjectend} + {\noindent\quad\texttt{object}\ocamldocindent} + {\endocamldocindent\vskip -\lastskip + \noindent\quad\texttt{end}\medskip} diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml index 04bdedfd..fbc612ba 100644 --- a/ocamldoc/odoc.ml +++ b/ocamldoc/odoc.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc.ml,v 1.7.4.1 2004/07/09 10:42:09 guesdon Exp $ *) (** Main module for bytecode. *) @@ -18,6 +19,8 @@ open Misc open Format open Typedtree +module M = Odoc_messages + let print_DEBUG s = print_string s ; print_newline () (* we check if we must load a module given on the command line *) @@ -39,6 +42,26 @@ let (cmo_or_cma_opt, paths) = let _ = print_DEBUG "Fin analyse des arguments pour le dynamic load" +(** Return the real name of the file to load, + searching it in the paths if it is + a simple name and not in the current directory. *) +let get_real_filename name = + if Filename.basename name <> name then + name + else + ( + let paths = Filename.current_dir_name :: paths @ [Odoc_config.custom_generators_path] in + try + let d = List.find + (fun d -> Sys.file_exists (Filename.concat d name)) + paths + in + Filename.concat d name + with + Not_found -> + failwith (M.file_not_found_in_paths paths name) + ) + let _ = match cmo_or_cma_opt with None -> @@ -48,9 +71,8 @@ let _ = Dynlink.init (); Dynlink.allow_unsafe_modules true; try - Dynlink.add_available_units Odoc_crc.crc_unit_list ; - let _ = Dynlink.loadfile file in - () + let real_file = get_real_filename file in + ignore(Dynlink.loadfile real_file) with Dynlink.Error e -> prerr_endline (Odoc_messages.load_file_error file (Dynlink.error_message e)) ; @@ -58,7 +80,8 @@ let _ = | Not_found -> prerr_endline (Odoc_messages.load_file_error file "Not_found"); exit 1 - | Sys_error s -> + | Sys_error s + | Failure s -> prerr_endline (Odoc_messages.load_file_error file s); exit 1 @@ -124,3 +147,4 @@ let _ = exit 0 +(* eof $Id: odoc.ml,v 1.7.4.1 2004/07/09 10:42:09 guesdon Exp $ *) diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index e7f27654..98cfb3ac 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_analyse.ml,v 1.8 2003/11/24 10:39:28 starynke Exp $ *) (** Analysis of source files. This module is strongly inspired from driver/main.ml :-) *) @@ -444,3 +445,4 @@ let load_modules file = raise (Failure s) +(* eof $Id: odoc_analyse.ml,v 1.8 2003/11/24 10:39:28 starynke Exp $ *) diff --git a/ocamldoc/odoc_analyse.mli b/ocamldoc/odoc_analyse.mli index 4b1254b8..c2b7165c 100644 --- a/ocamldoc/odoc_analyse.mli +++ b/ocamldoc/odoc_analyse.mli @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_analyse.mli,v 1.3 2003/11/24 10:39:28 starynke Exp $ *) (** Analysis of source files. *) diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index 9d761e2c..4e7601ff 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -9,8 +9,10 @@ (* *) (***********************************************************************) +(* cvsid $Id: odoc_args.ml,v 1.15.6.1 2004/07/09 14:32:42 guesdon Exp $ *) (** Command-line arguments. *) + open Clflags module M = Odoc_messages @@ -36,7 +38,7 @@ let dot_types = ref false let dot_reduce = ref false -let dot_colors = ref M.default_dot_colors +let dot_colors = ref (List.flatten M.default_dot_colors) let man_suffix = ref M.default_man_suffix @@ -102,6 +104,8 @@ let inverse_merge_ml_mli = ref false let title = ref (None : string option) +let intro_file = ref (None : string option) + let with_parameter_list = ref false let hidden_modules = ref ([] : string list) @@ -219,8 +223,11 @@ let options = ref [ "-load", Arg.String (fun s -> load := !load @ [s]), M.load^"\n" ; "-t", Arg.String (fun s -> title := Some s), M.option_title ; + "-intro", Arg.String (fun s -> intro_file := Some s), M.option_intro ; "-hide", Arg.String add_hidden_modules, M.hide_modules ; - "-m", Arg.String (fun s -> merge_options := !merge_options @ (analyse_merge_options s)), M.merge_options^"\n" ; + "-m", Arg.String (fun s -> merge_options := !merge_options @ (analyse_merge_options s)), + M.merge_options ^ + "\n\n *** choosing a generator ***\n"; (* generators *) "-html", Arg.Unit (fun () -> set_doc_generator !default_html_generator), M.generate_html ; @@ -228,14 +235,20 @@ let options = ref [ "-texi", Arg.Unit (fun () -> set_doc_generator !default_texi_generator), M.generate_texinfo ; "-man", Arg.Unit (fun () -> set_doc_generator !default_man_generator), M.generate_man ; "-dot", Arg.Unit (fun () -> set_doc_generator !default_dot_generator), M.generate_dot ; + "-customdir", Arg.Unit (fun () -> Printf.printf "%s\n" Odoc_config.custom_generators_path; exit 0), + M.display_custom_generators_dir ; + "-i", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-i"); exit 1)), + M.add_load_dir ; "-g", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-g"); exit 1)), - M.load_file^"\n" ; + M.load_file ^ + "\n\n *** HTML options ***\n"; (* html only options *) "-all-params", Arg.Set with_parameter_list, M.with_parameter_list ; "-css-style", Arg.String (fun s -> css_style := Some s), M.css_style ; "-index-only", Arg.Set index_only, M.index_only ; - "-colorize-code", Arg.Set colorize_code, M.colorize_code^"\n" ; + "-colorize-code", Arg.Set colorize_code, M.colorize_code ^ + "\n\n *** LaTeX options ***\n"; (* latex only options *) "-noheader", Arg.Unit (fun () -> with_header := false), M.no_header ; @@ -251,19 +264,24 @@ let options = ref [ "-latex-module-type-prefix", Arg.String (fun s -> latex_module_type_prefix := s), M.latex_module_type_prefix ; "-latex-class-prefix", Arg.String (fun s -> latex_class_prefix := s), M.latex_class_prefix ; "-latex-class-type-prefix", Arg.String (fun s -> latex_class_type_prefix := s), M.latex_class_type_prefix ; - "-notoc", Arg.Unit (fun () -> with_toc := false), M.no_toc^"\n" ; + "-notoc", Arg.Unit (fun () -> with_toc := false), + M.no_toc ^ + "\n\n *** texinfo options ***\n"; (* tex only options *) "-noindex", Arg.Clear with_index, M.no_index ; "-esc8", Arg.Set esc_8bits, M.esc_8bits ; "-info-section", Arg.String ((:=) info_section), M.info_section ; - "-info-entry", Arg.String (fun s -> info_entry := !info_entry @ [ s ]), M.info_entry ; + "-info-entry", Arg.String (fun s -> info_entry := !info_entry @ [ s ]), + M.info_entry ^ + "\n\n *** dot options ***\n"; (* dot only options *) "-dot-colors", Arg.String (fun s -> dot_colors := Str.split (Str.regexp_string ",") s), M.dot_colors ; "-dot-include-all", Arg.Set dot_include_all, M.dot_include_all ; "-dot-types", Arg.Set dot_types, M.dot_types ; - "-dot-reduce", Arg.Set dot_reduce, M.dot_reduce ; + "-dot-reduce", Arg.Set dot_reduce, M.dot_reduce^ + "\n\n *** man pages options ***\n"; (* man only options *) "-man-mini", Arg.Set man_mini, M.man_mini ; @@ -299,3 +317,4 @@ let parse ~html_generator ~latex_generator ~texi_generator ~man_generator ~dot_g hidden_modules := List.sort (fun a -> fun b -> - (compare a b)) !hidden_modules +(* eof $Id: odoc_args.ml,v 1.15.6.1 2004/07/09 14:32:42 guesdon Exp $ *) diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli index e2837819..64b839ec 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_args.mli,v 1.12 2003/11/24 10:39:29 starynke Exp $ *) (** Analysis of the command line arguments. *) @@ -65,6 +66,9 @@ val inverse_merge_ml_mli : bool ref (** The optional title to use in the generated documentation. *) val title : string option ref +(** The optional file whose content can be used as intro text. *) +val intro_file : string option ref + (** Flag to indicate whether we must display the complete list of parameters for functions and methods. *) val with_parameter_list : bool ref diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index d45d62c2..7d642701 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_ast.ml,v 1.24 2004/04/17 12:36:14 guesdon Exp $ *) (** Analysis of implementation files. *) open Misc @@ -384,6 +385,17 @@ module Analyser = (** This function takes a Typedtree.class_expr and returns a string which can stand for the class name. The name can be "object ... end" if the class expression is not an ident or a class constraint or a class apply. *) let rec tt_name_of_class_expr clexp = +(* + ( + match clexp.Typedtree.cl_desc with + Tclass_ident _ -> prerr_endline "Tclass_ident" + | Tclass_structure _ -> prerr_endline "Tclass_structure" + | Tclass_fun _ -> prerr_endline "Tclass_fun" + | Tclass_apply _ -> prerr_endline "Tclass_apply" + | Tclass_let _ -> prerr_endline "Tclass_let" + | Tclass_constraint _ -> prerr_endline "Tclass_constraint" + ); +*) match clexp.Typedtree.cl_desc with Typedtree.Tclass_ident p -> Name.from_path p | Typedtree.Tclass_constraint (class_expr, _, _, _) @@ -494,10 +506,19 @@ module Analyser = try Typedtree_search.get_nth_inherit_class_expr tt_cls n with Not_found -> raise (Failure (Odoc_messages.inherit_classexp_not_found_in_typedtree n)) in - let (info_opt, ele_comments) = get_comments_in_class last_pos p_clexp.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum in + let (info_opt, ele_comments) = + get_comments_in_class last_pos + p_clexp.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum + in let text_opt = match info_opt with None -> None | Some i -> i.Odoc_types.i_desc in let name = tt_name_of_class_expr tt_clexp in - let inher = { ic_name = Odoc_env.full_class_or_class_type_name env name ; ic_class = None ; ic_text = text_opt } in + let inher = + { + ic_name = Odoc_env.full_class_or_class_type_name env name ; + ic_class = None ; + ic_text = text_opt ; + } + in iter (acc_inher @ [ inher ]) (acc_fields @ ele_comments) p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum q @@ -804,6 +825,7 @@ module Analyser = { (* A VOIR : chercher dans les modules et les module types, avec quel env ? *) im_name = tt_name_from_module_expr mod_expr ; im_module = None ; + im_info = None ; } ] | _ -> @@ -818,7 +840,8 @@ module Analyser = | ([], _) -> [] | ((Element_included_module im) :: q, (im_repl :: im_q)) -> - (Element_included_module im_repl) :: (f (q, im_q)) + (Element_included_module { im_repl with im_info = im.im_info }) + :: (f (q, im_q)) | ((Element_included_module im) :: q, []) -> (Element_included_module im) :: q | (ele :: q, l) -> @@ -1101,7 +1124,7 @@ module Analyser = (* of string * module_expr *) try let tt_module_expr = Typedtree_search.search_module table name in - let new_module = analyse_module + let new_module_pre = analyse_module env current_module_name name @@ -1109,6 +1132,18 @@ module Analyser = module_expr tt_module_expr in + let code = + if !Odoc_args.keep_code then + let loc = module_expr.Parsetree.pmod_loc in + let st = loc.Location.loc_start.Lexing.pos_cnum in + let en = loc.Location.loc_end.Lexing.pos_cnum in + Some (get_string_of_file st en) + else + None + in + let new_module = + { new_module_pre with m_code = code } + in let new_env = Odoc_env.add_module env new_module.m_name in let new_env2 = match new_module.m_type with @@ -1127,6 +1162,8 @@ module Analyser = ) | Parsetree.Pstr_recmodule mods -> + (* A VOIR ICI ca merde avec /work/tmp/graph.ml: pas de lien avec les module type + dans les contraintes sur les modules *) let new_env = List.fold_left (fun acc_env (name, _, mod_exp) -> @@ -1338,6 +1375,7 @@ module Analyser = { im_name = "dummy" ; im_module = None ; + im_info = comment_opt ; } in (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *) @@ -1347,17 +1385,31 @@ module Analyser = let complete_name = Name.concat current_module_name module_name in let pos_start = p_module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in let pos_end = p_module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in - let modtype = tt_module_expr.Typedtree.mod_type in + let modtype = + (* A VOIR : Odoc_env.subst_module_type env ? *) + tt_module_expr.Typedtree.mod_type + in + let m_code_intf = + match p_module_expr.Parsetree.pmod_desc with + Parsetree.Pmod_constraint (_, pmodule_type) -> + let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + Some (get_string_of_file loc_start loc_end) + | _ -> + None + in let m_base = { m_name = complete_name ; - m_type = tt_module_expr.Typedtree.mod_type ; + m_type = modtype ; m_info = comment_opt ; m_is_interface = false ; m_file = !file_name ; m_kind = Module_struct [] ; m_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ; m_top_deps = [] ; + m_code = None ; (* code is set by the caller, after the module is created *) + m_code_intf = m_code_intf ; } in match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with @@ -1373,33 +1425,45 @@ module Analyser = let elements2 = replace_dummy_included_modules elements included_modules_from_tt in { m_base with m_kind = Module_struct elements2 } - | (Parsetree.Pmod_functor (_, _, p_module_expr2), + | (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2), Typedtree.Tmod_functor (ident, mtyp, tt_module_expr2)) -> - let param = - { - mp_name = Name.from_ident ident ; - mp_type = Odoc_env.subst_module_type env mtyp ; - } - in - let dummy_complete_name = Name.concat "__" param.mp_name in - let new_env = Odoc_env.add_module env dummy_complete_name in - let m_base2 = analyse_module - new_env - current_module_name - module_name - None - p_module_expr2 - tt_module_expr2 - in - let kind = - match m_base2.m_kind with - Module_functor (params, k) -> Module_functor (param :: params, m_base2.m_kind) - | k -> Module_functor ([param], k) - in - { m_base with m_kind = kind } + let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let mp_type_code = get_string_of_file loc_start loc_end in + print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); + let mp_name = Name.from_ident ident in + let mp_kind = Sig.analyse_module_type_kind env + current_module_name pmodule_type mtyp + in + let param = + { + mp_name = mp_name ; + mp_type = Odoc_env.subst_module_type env mtyp ; + mp_type_code = mp_type_code ; + mp_kind = mp_kind ; + } + in + let dummy_complete_name = (*Name.concat "__"*) param.mp_name in + (* TODO: A VOIR CE __ *) + let new_env = Odoc_env.add_module env dummy_complete_name in + let m_base2 = analyse_module + new_env + current_module_name + module_name + None + p_module_expr2 + tt_module_expr2 + in + let kind = m_base2.m_kind in + { m_base with m_kind = Module_functor (param, kind) } | (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2), - Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)) -> + Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)) + | (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2), + Typedtree.Tmod_constraint + ({ Typedtree.mod_desc = Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)}, + _, _) + ) -> let m1 = analyse_module env current_module_name @@ -1420,6 +1484,8 @@ module Analyser = | (Parsetree.Pmod_constraint (p_module_expr2, p_modtype), Typedtree.Tmod_constraint (tt_module_expr2, tt_modtype, _)) -> + print_DEBUG ("Odoc_ast: case Parsetree.Pmod_constraint + Typedtree.Tmod_constraint "^module_name); + (* we create the module with p_module_expr2 and tt_module_expr2 but we change its type according to the constraint. A VOIR : est-ce que c'est bien ? @@ -1439,7 +1505,7 @@ module Analyser = in { m_base with - m_type = tt_modtype ; + m_type = Odoc_env.subst_module_type env tt_modtype ; m_kind = Module_constraint (m_base2.m_kind, mtkind) @@ -1454,13 +1520,37 @@ module Analyser = tt_modtype, _) ) -> (* needed for recursive modules *) + + print_DEBUG ("Odoc_ast: case Parsetree.Pmod_structure + Typedtree.Tmod_constraint "^module_name); let elements = analyse_structure env complete_name pos_start pos_end p_structure tt_structure in (* we must complete the included modules *) let included_modules_from_tt = tt_get_included_module_list tt_structure in let elements2 = replace_dummy_included_modules elements included_modules_from_tt in - { m_base with m_kind = Module_struct elements2 } - - | _ -> + { m_base with + m_type = Odoc_env.subst_module_type env tt_modtype ; + m_kind = Module_struct elements2 ; + } + + | (parsetree, typedtree) -> + let s_parse = + match parsetree with + Parsetree.Pmod_ident _ -> "Pmod_ident" + | Parsetree.Pmod_structure _ -> "Pmod_structure" + | Parsetree.Pmod_functor _ -> "Pmod_functor" + | Parsetree.Pmod_apply _ -> "Pmod_apply" + | Parsetree.Pmod_constraint _ -> "Pmod_constraint" + in + let s_typed = + match typedtree with + Typedtree.Tmod_ident _ -> "Tmod_ident" + | Typedtree.Tmod_structure _ -> "Tmod_structure" + | Typedtree.Tmod_functor _ -> "Tmod_functor" + | Typedtree.Tmod_apply _ -> "Tmod_apply" + | Typedtree.Tmod_constraint _ -> "Tmod_constraint" + in + let code = get_string_of_file pos_start pos_end in + print_DEBUG (Printf.sprintf "code=%s\ns_parse=%s\ns_typed=%s\n" code s_parse s_typed); + raise (Failure "analyse_module: parsetree and typedtree don't match.") let analyse_typed_tree source_file input_file @@ -1490,20 +1580,20 @@ module Analyser = let included_modules_from_tt = tt_get_included_module_list tree_structure in let elements2 = replace_dummy_included_modules elements included_modules_from_tt in let kind = Module_struct elements2 in - let m = - { - m_name = mod_name ; - m_type = Types.Tmty_signature [] ; - m_info = info_opt ; - m_is_interface = false ; - m_file = !file_name ; - m_kind = kind ; - m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ; - m_top_deps = [] ; - } - in - m + { + m_name = mod_name ; + m_type = Types.Tmty_signature [] ; + m_info = info_opt ; + m_is_interface = false ; + m_file = !file_name ; + m_kind = kind ; + m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ; + m_top_deps = [] ; + m_code = (if !Odoc_args.keep_code then Some !file else None) ; + m_code_intf = None ; + } end +(* eof $Id: odoc_ast.ml,v 1.24 2004/04/17 12:36:14 guesdon Exp $ *) diff --git a/ocamldoc/odoc_ast.mli b/ocamldoc/odoc_ast.mli index 458365b0..b68b7774 100644 --- a/ocamldoc/odoc_ast.mli +++ b/ocamldoc/odoc_ast.mli @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_ast.mli,v 1.4 2003/11/24 10:39:29 starynke Exp $ *) (** The module for analysing the typed abstract syntax tree and source code and creating modules, classes, ..., elements.*) diff --git a/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml index fc367765..c2848b8b 100644 --- a/ocamldoc/odoc_class.ml +++ b/ocamldoc/odoc_class.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_class.ml,v 1.5 2004/03/26 15:57:02 guesdon Exp $ *) (** Representation and manipulation of classes and class types.*) @@ -35,7 +36,7 @@ and class_apply = { capp_name : Name.t ; (** The complete name of the applied class *) mutable capp_class : t_class option; (** The associated t_class if we found it *) capp_params : Types.type_expr list; (** The type of expressions the class is applied to *) - capp_params_code : string list ; (** The code of these exprssions *) + capp_params_code : string list ; (** The code of these expressions *) } and class_constr = { @@ -249,3 +250,4 @@ let class_type_parameter_text_by_name clt label = None +(* eof $Id: odoc_class.ml,v 1.5 2004/03/26 15:57:02 guesdon Exp $ *) diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml index 2b1d1f6f..474ea361 100644 --- a/ocamldoc/odoc_comments.ml +++ b/ocamldoc/odoc_comments.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_comments.ml,v 1.4 2003/11/24 10:39:29 starynke Exp $ *) (** Analysis of comments. *) @@ -310,3 +311,5 @@ module Info_retriever = end module Basic_info_retriever = Info_retriever (Odoc_text.Texter) + +(* eof $Id: odoc_comments.ml,v 1.4 2003/11/24 10:39:29 starynke Exp $ *) diff --git a/ocamldoc/odoc_comments.mli b/ocamldoc/odoc_comments.mli index 349ccaf9..7bbc9aa3 100644 --- a/ocamldoc/odoc_comments.mli +++ b/ocamldoc/odoc_comments.mli @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_comments.mli,v 1.3 2003/11/24 10:39:30 starynke Exp $ *) (** Analysis of comments. *) diff --git a/ocamldoc/odoc_comments_global.ml b/ocamldoc/odoc_comments_global.ml index e2149bce..92846af1 100644 --- a/ocamldoc/odoc_comments_global.ml +++ b/ocamldoc/odoc_comments_global.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_comments_global.ml,v 1.2 2003/11/24 10:39:30 starynke Exp $ *) (** The global variables used by the special comment parser.*) @@ -44,3 +45,4 @@ let init () = return_value := None ; customs := [] +(* eof $Id: odoc_comments_global.ml,v 1.2 2003/11/24 10:39:30 starynke Exp $ *) diff --git a/ocamldoc/odoc_comments_global.mli b/ocamldoc/odoc_comments_global.mli index 69116d55..c29d074f 100644 --- a/ocamldoc/odoc_comments_global.mli +++ b/ocamldoc/odoc_comments_global.mli @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_comments_global.mli,v 1.2 2003/11/24 10:39:30 starynke Exp $ *) (** The global variables used by the special comment parser.*) diff --git a/ocamldoc/odoc_config.ml b/ocamldoc/odoc_config.ml new file mode 100644 index 00000000..7538576e --- /dev/null +++ b/ocamldoc/odoc_config.ml @@ -0,0 +1,16 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Maxence Guesdon, 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: odoc_config.ml,v 1.1 2004/01/28 13:36:20 guesdon Exp $ *) + +let custom_generators_path = + Filename.concat Config.standard_library + (Filename.concat "ocamldoc" "custom") diff --git a/ocamldoc/odoc_config.mli b/ocamldoc/odoc_config.mli new file mode 100644 index 00000000..63ec18b2 --- /dev/null +++ b/ocamldoc/odoc_config.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Maxence Guesdon, 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: odoc_config.mli,v 1.1 2004/01/28 13:36:20 guesdon Exp $ *) + +(** Ocamldoc configuration contants. *) + +(** Default path to search for custom generators and to install them. *) +val custom_generators_path : string diff --git a/ocamldoc/odoc_control.ml b/ocamldoc/odoc_control.ml index 7519a782..979b9ad0 100644 --- a/ocamldoc/odoc_control.ml +++ b/ocamldoc/odoc_control.ml @@ -9,5 +9,5 @@ (* *) (***********************************************************************) - +(* $Id: odoc_control.ml,v 1.2 2003/11/24 10:39:30 starynke Exp $ *) diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml index d9f99f38..191871f3 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_cross.ml,v 1.15 2004/05/23 10:41:49 guesdon Exp $ *) (** Cross referencing. *) @@ -67,139 +68,213 @@ module P_alias = (** The module used to get the aliased elements. *) module Search_alias = Odoc_search.Search (P_alias) -let rec build_alias_list (acc_m, acc_mt, acc_ex) = function - [] -> - (acc_m, acc_mt, acc_ex) - | (Odoc_search.Res_module m) :: q -> - let new_acc_m = - match m.m_kind with - Module_alias ma -> (m.m_name, ma.ma_name) :: acc_m - | _ -> acc_m - in - build_alias_list (new_acc_m, acc_mt, acc_ex) q - | (Odoc_search.Res_module_type mt) :: q -> - let new_acc_mt = - match mt.mt_kind with - Some (Module_type_alias mta) -> (mt.mt_name, mta.mta_name) :: acc_mt - | _ -> acc_mt - in - build_alias_list (acc_m, new_acc_mt, acc_ex) q - | (Odoc_search.Res_exception e) :: q -> - let new_acc_ex = - match e.ex_alias with - None -> acc_ex - | Some ea -> (e.ex_name, ea.ea_name) :: acc_ex - in - build_alias_list (acc_m, acc_mt, new_acc_ex) q - | _ :: q -> - build_alias_list (acc_m, acc_mt, acc_ex) q - - +type alias_state = + Alias_resolved + | Alias_to_resolve (** Couples of module name aliases. *) -let module_aliases = ref [] ;; +let (module_aliases : (Name.t, Name.t * alias_state) Hashtbl.t) = Hashtbl.create 13 ;; -(** Couples of module type name aliases. *) -let module_type_aliases = ref [] ;; +(** Couples of module or module type name aliases. *) +let module_and_modtype_aliases = Hashtbl.create 13;; (** Couples of exception name aliases. *) -let exception_aliases = ref [] ;; +let exception_aliases = Hashtbl.create 13;; -(** Retrieve the aliases for modules, module types and exceptions and put them in global variables. *) +let rec build_alias_list = function + [] -> () + | (Odoc_search.Res_module m) :: q -> + ( + match m.m_kind with + Module_alias ma -> + Hashtbl.add module_aliases m.m_name (ma.ma_name, Alias_to_resolve); + Hashtbl.add module_and_modtype_aliases m.m_name (ma.ma_name, Alias_to_resolve) + | _ -> () + ); + build_alias_list q + | (Odoc_search.Res_module_type mt) :: q -> + ( + match mt.mt_kind with + Some (Module_type_alias mta) -> + Hashtbl.add module_and_modtype_aliases + mt.mt_name (mta.mta_name, Alias_to_resolve) + | _ -> () + ); + build_alias_list q + | (Odoc_search.Res_exception e) :: q -> + ( + match e.ex_alias with + None -> () + | Some ea -> + Hashtbl.add exception_aliases + e.ex_name (ea.ea_name,Alias_to_resolve) + ); + build_alias_list q + | _ :: q -> + build_alias_list q + +(** Retrieve the aliases for modules, module types and exceptions + and put them in global hash tables. *) let get_alias_names module_list = - let (alias_m, alias_mt, alias_ex) = - build_alias_list - ([], [], []) - (Search_alias.search module_list 0) - in - module_aliases := alias_m ; - module_type_aliases := alias_mt ; - exception_aliases := alias_ex + Hashtbl.clear module_aliases; + Hashtbl.clear module_and_modtype_aliases; + Hashtbl.clear exception_aliases; + build_alias_list (Search_alias.search module_list 0) +exception Found of string +let name_alias = + let rec f t name = + try + match Hashtbl.find t name with + (s, Alias_resolved) -> s + | (s, Alias_to_resolve) -> f t s + with + Not_found -> + try + Hashtbl.iter + (fun n2 (n3, _) -> + if Name.prefix n2 name then + let ln2 = String.length n2 in + let s = n3^(String.sub name ln2 ((String.length name) - ln2)) in + raise (Found s) + ) + t ; + Hashtbl.replace t name (name, Alias_resolved); + name + with + Found s -> + let s2 = f t s in + Hashtbl.replace t s2 (s2, Alias_resolved); + s2 + in + fun name alias_tbl -> + f alias_tbl name + -(** The module with lookup predicates. *) -module P_lookup = +module Map_ord = struct - type t = Name.t - let p_module m name = (Name.prefix m.m_name name, m.m_name = (Name.name_alias name !module_aliases)) - let p_module_type mt name = (Name.prefix mt.mt_name name, mt.mt_name = (Name.name_alias name (!module_aliases @ !module_type_aliases))) - let p_class c name = (false, c.cl_name = (Name.name_alias name (!module_aliases @ !module_type_aliases))) - let p_class_type ct name = (false, ct.clt_name = (Name.name_alias name (!module_aliases @ !module_type_aliases))) - let p_value v name = false - let p_type t name = false - let p_exception e name = e.ex_name = (Name.name_alias name !exception_aliases) - let p_attribute a name = false - let p_method m name = false - let p_section s name = false + type t = string + let compare = Pervasives.compare end -(** The module used to search by a complete name.*) -module Search_by_complete_name = Odoc_search.Search (P_lookup) - -let rec lookup_module module_list name = - let l = List.filter - (fun res -> - match res with - Odoc_search.Res_module _ -> true - | _ -> false - ) - (Search_by_complete_name.search module_list name) - in - match l with - (Odoc_search.Res_module m) :: _ -> m - | _ -> raise Not_found - -let rec lookup_module_type module_list name = - let l = List.filter - (fun res -> - match res with - Odoc_search.Res_module_type _ -> true - | _ -> false - ) - (Search_by_complete_name.search module_list name) - in - match l with - (Odoc_search.Res_module_type mt) :: _ -> mt - | _ -> raise Not_found - -let rec lookup_class module_list name = - let l = List.filter - (fun res -> - match res with - Odoc_search.Res_class _ -> true - | _ -> false - ) - (Search_by_complete_name.search module_list name) - in - match l with - (Odoc_search.Res_class c) :: _ -> c - | _ -> raise Not_found - -let rec lookup_class_type module_list name = - let l = List.filter - (fun res -> - match res with - Odoc_search.Res_class_type _ -> true - | _ -> false - ) - (Search_by_complete_name.search module_list name) - in - match l with - (Odoc_search.Res_class_type ct) :: _ -> ct - | _ -> raise Not_found - -let rec lookup_exception module_list name = - let l = List.filter - (fun res -> - match res with - Odoc_search.Res_exception _ -> true - | _ -> false - ) - (Search_by_complete_name.search module_list name) +module Ele_map = Map.Make (Map_ord) + +let known_elements = ref Ele_map.empty +let add_known_element name k = + try + let l = Ele_map.find name !known_elements in + let s = Ele_map.remove name !known_elements in + known_elements := Ele_map.add name (k::l) s + with + Not_found -> + known_elements := Ele_map.add name [k] !known_elements + +let get_known_elements name = + try Ele_map.find name !known_elements + with Not_found -> [] + +let kind_name_exists kind = + let pred = + match kind with + RK_module -> (fun e -> match e with Odoc_search.Res_module _ -> true | _ -> false) + | RK_module_type -> (fun e -> match e with Odoc_search.Res_module_type _ -> true | _ -> false) + | RK_class -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) + | RK_class_type -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) + | RK_value -> (fun e -> match e with Odoc_search.Res_value _ -> true | _ -> false) + | RK_type -> (fun e -> match e with Odoc_search.Res_type _ -> true | _ -> false) + | RK_exception -> (fun e -> match e with Odoc_search.Res_exception _ -> true | _ -> false) + | RK_attribute -> (fun e -> match e with Odoc_search.Res_attribute _ -> true | _ -> false) + | RK_method -> (fun e -> match e with Odoc_search.Res_method _ -> true | _ -> false) + | RK_section _ -> assert false in - match l with - (Odoc_search.Res_exception e) :: _ -> e - | _ -> raise Not_found + fun name -> + try List.exists pred (get_known_elements name) + with Not_found -> false + +let module_exists = kind_name_exists RK_module +let module_type_exists = kind_name_exists RK_module_type +let class_exists = kind_name_exists RK_class +let class_type_exists = kind_name_exists RK_class_type +let value_exists = kind_name_exists RK_value +let type_exists = kind_name_exists RK_type +let exception_exists = kind_name_exists RK_exception +let attribute_exists = kind_name_exists RK_attribute +let method_exists = kind_name_exists RK_method + +let lookup_module name = + match List.find + (fun k -> match k with Odoc_search.Res_module _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_module m -> m + | _ -> assert false + +let lookup_module_type name = + match List.find + (fun k -> match k with Odoc_search.Res_module_type _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_module_type m -> m + | _ -> assert false + +let lookup_class name = + match List.find + (fun k -> match k with Odoc_search.Res_class _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_class c -> c + | _ -> assert false + +let lookup_class_type name = + match List.find + (fun k -> match k with Odoc_search.Res_class_type _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_class_type c -> c + | _ -> assert false + +let lookup_exception name = + match List.find + (fun k -> match k with Odoc_search.Res_exception _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_exception e -> e + | _ -> assert false + +class scan = + object + inherit Odoc_scan.scanner + method scan_value v = + add_known_element v.val_name (Odoc_search.Res_value v) + method scan_type t = + add_known_element t.ty_name (Odoc_search.Res_type t) + method scan_exception e = + add_known_element e.ex_name (Odoc_search.Res_exception e) + method scan_attribute a = + add_known_element a.att_value.val_name + (Odoc_search.Res_attribute a) + method scan_method m = + add_known_element m.met_value.val_name + (Odoc_search.Res_method m) + method scan_class_pre c = + add_known_element c.cl_name (Odoc_search.Res_class c); + true + method scan_class_type_pre c = + add_known_element c.clt_name (Odoc_search.Res_class_type c); + true + method scan_module_pre m = + add_known_element m.m_name (Odoc_search.Res_module m); + true + method scan_module_type_pre m = + add_known_element m.mt_name (Odoc_search.Res_module_type m); + true + + end + +let init_known_elements_map module_list = + let c = new scan in + c#scan_module_list module_list + (** The type to describe the names not found. *) type not_found_name = @@ -229,9 +304,9 @@ let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_ (acc_b, acc_inc, acc_names) | None -> let mmt_opt = - try Some (Mod (lookup_module module_list ma.ma_name)) + try Some (Mod (lookup_module ma.ma_name)) with Not_found -> - try Some (Modtype (lookup_module_type module_list ma.ma_name)) + try Some (Modtype (lookup_module_type ma.ma_name)) with Not_found -> None in match mmt_opt with @@ -292,7 +367,7 @@ and associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module (acc_b, acc_inc, acc_names) | None -> let mt_opt = - try Some (lookup_module_type module_list mta.mta_name) + try Some (lookup_module_type mta.mta_name) with Not_found -> None in match mt_opt with @@ -323,9 +398,9 @@ and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_ Some _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) | None -> let mmt_opt = - try Some (Mod (lookup_module module_list im.im_name)) + try Some (Mod (lookup_module im.im_name)) with Not_found -> - try Some (Modtype (lookup_module_type module_list im.im_name)) + try Some (Modtype (lookup_module_type im.im_name)) with Not_found -> None in match mmt_opt with @@ -355,7 +430,7 @@ and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_ (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) | None -> let ex_opt = - try Some (lookup_exception module_list ea.ea_name) + try Some (lookup_exception ea.ea_name) with Not_found -> None in match ex_opt with @@ -376,9 +451,9 @@ and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names Some _ -> (acc_b2, acc_inc2, acc_names2) | None -> let cct_opt = - try Some (Cl (lookup_class module_list ic.ic_name)) + try Some (Cl (lookup_class ic.ic_name)) with Not_found -> - try Some (Cltype (lookup_class_type module_list ic.ic_name, [])) + try Some (Cltype (lookup_class_type ic.ic_name, [])) with Not_found -> None in match cct_opt with @@ -397,7 +472,7 @@ and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names Some _ -> (acc_b, acc_inc, acc_names) | None -> let cl_opt = - try Some (lookup_class module_list capp.capp_name) + try Some (lookup_class capp.capp_name) with Not_found -> None in match cl_opt with @@ -415,14 +490,14 @@ and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names Some _ -> (acc_b, acc_inc, acc_names) | None -> let cl_opt = - try Some (lookup_class module_list cco.cco_name) + try Some (lookup_class cco.cco_name) with Not_found -> None in match cl_opt with None -> ( let clt_opt = - try Some (lookup_class_type module_list cco.cco_name) + try Some (lookup_class_type cco.cco_name) with Not_found -> None in match clt_opt with @@ -459,9 +534,9 @@ and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_ Some _ -> (acc_b2, acc_inc2, acc_names2) | None -> let cct_opt = - try Some (Cltype (lookup_class_type module_list ic.ic_name, [])) + try Some (Cltype (lookup_class_type ic.ic_name, [])) with Not_found -> - try Some (Cl (lookup_class module_list ic.ic_name)) + try Some (Cl (lookup_class ic.ic_name)) with Not_found -> None in match cct_opt with @@ -480,9 +555,9 @@ and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_ Some _ -> (acc_b, acc_inc, acc_names) | None -> let cct_opt = - try Some (Cltype (lookup_class_type module_list cta.cta_name, [])) + try Some (Cltype (lookup_class_type cta.cta_name, [])) with Not_found -> - try Some (Cl (lookup_class module_list cta.cta_name)) + try Some (Cl (lookup_class cta.cta_name)) with Not_found -> None in match cct_opt with @@ -503,97 +578,109 @@ let ao = Odoc_misc.apply_opt let rec assoc_comments_text_elements module_list t_ele = match t_ele with - | Raw _ - | Code _ - | CodePre _ - | Latex _ - | Verbatim _ -> t_ele - | Bold t -> Bold (assoc_comments_text module_list t) - | Italic t -> Italic (assoc_comments_text module_list t) - | Center t -> Center (assoc_comments_text module_list t) - | Left t -> Left (assoc_comments_text module_list t) - | Right t -> Right (assoc_comments_text module_list t) - | Emphasize t -> Emphasize (assoc_comments_text module_list t) - | List l -> List (List.map (assoc_comments_text module_list) l) - | Enum l -> Enum (List.map (assoc_comments_text module_list) l) - | Newline -> Newline - | Block t -> Block (assoc_comments_text module_list t) - | Superscript t -> Superscript (assoc_comments_text module_list t) - | Subscript t -> Subscript (assoc_comments_text module_list t) - | Title (n, l_opt, t) -> Title (n, l_opt, (assoc_comments_text module_list t)) - | Link (s, t) -> Link (s, (assoc_comments_text module_list t)) - | Ref (name, None) -> - ( - (* we look for the first element with this name *) - let re = Str.regexp ("^"^(Str.quote name)^"$") in - let res = Odoc_search.Search_by_name.search module_list re in - match res with - [] -> - Odoc_messages.pwarning (Odoc_messages.cross_element_not_found name); - t_ele - | ele :: _ -> - let kind = - match ele with - Odoc_search.Res_module _ -> RK_module - | Odoc_search.Res_module_type _ -> RK_module_type - | Odoc_search.Res_class _ -> RK_class - | Odoc_search.Res_class_type _ -> RK_class_type - | Odoc_search.Res_value _ -> RK_value - | Odoc_search.Res_type _ -> RK_type - | Odoc_search.Res_exception _ -> RK_exception - | Odoc_search.Res_attribute _ -> RK_attribute - | Odoc_search.Res_method _ -> RK_method - | Odoc_search.Res_section (_ ,t)-> RK_section t - in - add_verified (name, Some kind) ; - Ref (name, Some kind) - ) - | Ref (name, Some kind) -> - let v = (name, Some kind) in - (** we just verify that we find an element of this kind with this name *) - let re = Str.regexp ("^"^(Str.quote name)^"$") in - let res = Odoc_search.Search_by_name.search module_list re in - if was_verified v then - Ref (name, Some kind) - else - match kind with - | RK_section _ -> - ( - try - let t = Odoc_search.find_section module_list re in - let v2 = (name, Some (RK_section t)) in - add_verified v2 ; - Ref (name, Some (RK_section t)) - with - Not_found -> - Odoc_messages.pwarning (Odoc_messages.cross_section_not_found name); - Ref (name, None) - ) - | _ -> - let (f,f_mes) = - match kind with - RK_module -> Odoc_search.module_exists, Odoc_messages.cross_module_not_found - | RK_module_type -> Odoc_search.module_type_exists, Odoc_messages.cross_module_type_not_found - | RK_class -> Odoc_search.class_exists, Odoc_messages.cross_class_not_found - | RK_class_type -> Odoc_search.class_type_exists, Odoc_messages.cross_class_type_not_found - | RK_value -> Odoc_search.value_exists, Odoc_messages.cross_value_not_found - | RK_type -> Odoc_search.type_exists, Odoc_messages.cross_type_not_found - | RK_exception -> Odoc_search.exception_exists, Odoc_messages.cross_exception_not_found - | RK_attribute -> Odoc_search.attribute_exists, Odoc_messages.cross_attribute_not_found - | RK_method -> Odoc_search.method_exists, Odoc_messages.cross_method_not_found - | RK_section _ -> assert false - in - if f module_list re then - ( - add_verified v ; - Ref (name, Some kind) - ) - else - ( - Odoc_messages.pwarning (f_mes name); - Ref (name, None) - ) - + | Raw _ + | Code _ + | CodePre _ + | Latex _ + | Verbatim _ -> t_ele + | Bold t -> Bold (assoc_comments_text module_list t) + | Italic t -> Italic (assoc_comments_text module_list t) + | Center t -> Center (assoc_comments_text module_list t) + | Left t -> Left (assoc_comments_text module_list t) + | Right t -> Right (assoc_comments_text module_list t) + | Emphasize t -> Emphasize (assoc_comments_text module_list t) + | List l -> List (List.map (assoc_comments_text module_list) l) + | Enum l -> Enum (List.map (assoc_comments_text module_list) l) + | Newline -> Newline + | Block t -> Block (assoc_comments_text module_list t) + | Superscript t -> Superscript (assoc_comments_text module_list t) + | Subscript t -> Subscript (assoc_comments_text module_list t) + | Title (n, l_opt, t) -> Title (n, l_opt, (assoc_comments_text module_list t)) + | Link (s, t) -> Link (s, (assoc_comments_text module_list t)) + | Ref (name, None) -> + ( + match get_known_elements name with + [] -> + ( + try + let re = Str.regexp ("^"^(Str.quote name)^"$") in + let t = Odoc_search.find_section module_list re in + let v2 = (name, Some (RK_section t)) in + add_verified v2 ; + Ref (name, Some (RK_section t)) + with + Not_found -> + Odoc_messages.pwarning (Odoc_messages.cross_element_not_found name); + Ref (name, None) + ) + | ele :: _ -> + (* we look for the first element with this name *) + let kind = + match ele with + Odoc_search.Res_module _ -> RK_module + | Odoc_search.Res_module_type _ -> RK_module_type + | Odoc_search.Res_class _ -> RK_class + | Odoc_search.Res_class_type _ -> RK_class_type + | Odoc_search.Res_value _ -> RK_value + | Odoc_search.Res_type _ -> RK_type + | Odoc_search.Res_exception _ -> RK_exception + | Odoc_search.Res_attribute _ -> RK_attribute + | Odoc_search.Res_method _ -> RK_method + | Odoc_search.Res_section (_ ,t)-> assert false + in + add_verified (name, Some kind) ; + Ref (name, Some kind) + ) + | Ref (name, Some kind) -> + ( + let v = (name, Some kind) in + if was_verified v then + Ref (name, Some kind) + else + match kind with + | RK_section _ -> + ( + (** we just verify that we find an element of this kind with this name *) + try + let re = Str.regexp ("^"^(Str.quote name)^"$") in + let t = Odoc_search.find_section module_list re in + let v2 = (name, Some (RK_section t)) in + add_verified v2 ; + Ref (name, Some (RK_section t)) + with + Not_found -> + Odoc_messages.pwarning (Odoc_messages.cross_section_not_found name); + Ref (name, None) + ) + | _ -> + let (f,f_mes) = + match kind with + RK_module -> module_exists, Odoc_messages.cross_module_not_found + | RK_module_type -> module_type_exists, Odoc_messages.cross_module_type_not_found + | RK_class -> class_exists, Odoc_messages.cross_class_not_found + | RK_class_type -> class_type_exists, Odoc_messages.cross_class_type_not_found + | RK_value -> value_exists, Odoc_messages.cross_value_not_found + | RK_type -> type_exists, Odoc_messages.cross_type_not_found + | RK_exception -> exception_exists, Odoc_messages.cross_exception_not_found + | RK_attribute -> attribute_exists, Odoc_messages.cross_attribute_not_found + | RK_method -> method_exists, Odoc_messages.cross_method_not_found + | RK_section _ -> assert false + in + if f name then + ( + add_verified v ; + Ref (name, Some kind) + ) + else + ( + Odoc_messages.pwarning (f_mes name); + Ref (name, None) + ) + ) + | Module_list l -> + Module_list l + | Index_list -> + Index_list and assoc_comments_text module_list text = List.map (assoc_comments_text_elements module_list) text @@ -761,6 +848,7 @@ let associate_type_of_elements_in_comments module_list = (** The function which performs all the cross referencing. *) let associate module_list = get_alias_names module_list ; + init_known_elements_map module_list; let rec remove_doubles acc = function [] -> acc | h :: q -> @@ -780,7 +868,7 @@ let associate module_list = (* we may be able to associate something else *) iter remaining_modules else - (* nothing changed, we won' be able to associate any more *) + (* nothing changed, we won't be able to associate any more *) acc_names_not_found in let names_not_found = iter module_list in @@ -807,6 +895,7 @@ let associate module_list = ) ; (* Find a type for each name of element which is referenced in comments. *) - let _ = associate_type_of_elements_in_comments module_list in - () + ignore (associate_type_of_elements_in_comments module_list) + +(* eof $Id: odoc_cross.ml,v 1.15 2004/05/23 10:41:49 guesdon Exp $ *) diff --git a/ocamldoc/odoc_cross.mli b/ocamldoc/odoc_cross.mli index d4c1d5cc..51d0823f 100644 --- a/ocamldoc/odoc_cross.mli +++ b/ocamldoc/odoc_cross.mli @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_cross.mli,v 1.2 2003/11/24 10:39:30 starynke Exp $ *) (** Cross-referencing. *) diff --git a/ocamldoc/odoc_dag2html.ml b/ocamldoc/odoc_dag2html.ml index 4231bab0..ad96b6a9 100644 --- a/ocamldoc/odoc_dag2html.ml +++ b/ocamldoc/odoc_dag2html.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_dag2html.ml,v 1.3 2003/11/24 10:39:30 starynke Exp $ *) (** The types and functions to create a html table representing a dag. Thanks to Daniel De Rauglaudre. *) diff --git a/ocamldoc/odoc_dag2html.mli b/ocamldoc/odoc_dag2html.mli index b66de064..a1bbf49f 100644 --- a/ocamldoc/odoc_dag2html.mli +++ b/ocamldoc/odoc_dag2html.mli @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_dag2html.mli,v 1.3 2003/11/24 10:39:31 starynke Exp $ *) (** The types and functions to create a html table representing a dag. Thanks to Daniel de Rauglaudre. *) diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index 096daa86..0f632fde 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -9,6 +9,8 @@ (* *) (***********************************************************************) +(* $Id: odoc_dep.ml,v 1.6 2004/03/05 14:57:50 guesdon Exp $ *) + (** Top modules dependencies. *) module StrS = Depend.StringSet @@ -150,7 +152,7 @@ let type_deps t = (fun c -> List.iter (fun e -> - let s = Odoc_misc.string_of_type_expr e in + let s = Odoc_print.string_of_type_expr e in ignore (Str.global_substitute re f s) ) c.T.vc_args @@ -159,7 +161,7 @@ let type_deps t = | T.Type_record (rl, _) -> List.iter (fun r -> - let s = Odoc_misc.string_of_type_expr r.T.rf_type in + let s = Odoc_print.string_of_type_expr r.T.rf_type in ignore (Str.global_substitute re f s) ) rl @@ -168,7 +170,7 @@ let type_deps t = (match t.T.ty_manifest with None -> () | Some e -> - let s = Odoc_misc.string_of_type_expr e in + let s = Odoc_print.string_of_type_expr e in ignore (Str.global_substitute re f s) ); diff --git a/ocamldoc/odoc_dot.ml b/ocamldoc/odoc_dot.ml index ed9275e7..99f9a965 100644 --- a/ocamldoc/odoc_dot.ml +++ b/ocamldoc/odoc_dot.ml @@ -9,6 +9,8 @@ (* *) (***********************************************************************) +(* $Id: odoc_dot.ml,v 1.6 2003/11/24 10:39:31 starynke Exp $ *) + (** Definition of a class which outputs a dot file showing top modules dependencies.*) diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index 5294d0ca..6845ce2c 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_env.ml,v 1.7 2004/06/12 08:55:46 xleroy Exp $ *) (** Environment for finding complete names from relative names. *) @@ -51,9 +52,9 @@ let rec add_signature env root ?rel signat = let f env item = match item with Types.Tsig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values } - | Types.Tsig_type (ident,_ ) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types } + | Types.Tsig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types } | Types.Tsig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions } - | Types.Tsig_module (ident, modtype) -> + | Types.Tsig_module (ident, modtype, _) -> let env2 = match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *) Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s @@ -72,8 +73,8 @@ let rec add_signature env root ?rel signat = | _ -> env in { env2 with env_module_types = (rel_name ident, qualify ident) :: env2.env_module_types } - | Types.Tsig_class (ident, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes } - | Types.Tsig_cltype (ident, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types } + | Types.Tsig_class (ident, _, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes } + | Types.Tsig_cltype (ident, _, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types } in List.fold_left f env signat @@ -240,3 +241,5 @@ let subst_class_type env t = Types.Tcty_fun (l, new_texp, new_ct) in iter t + +(* eof $Id: odoc_env.ml,v 1.7 2004/06/12 08:55:46 xleroy Exp $ *) diff --git a/ocamldoc/odoc_env.mli b/ocamldoc/odoc_env.mli index 698a3877..4e2cbe9e 100644 --- a/ocamldoc/odoc_env.mli +++ b/ocamldoc/odoc_env.mli @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_env.mli,v 1.3 2003/11/24 10:39:31 starynke Exp $ *) (** Environment for finding complete names from relative names. *) diff --git a/ocamldoc/odoc_exception.ml b/ocamldoc/odoc_exception.ml index b9e9428c..015915aa 100644 --- a/ocamldoc/odoc_exception.ml +++ b/ocamldoc/odoc_exception.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_exception.ml,v 1.3 2003/11/24 10:39:31 starynke Exp $ *) (** Representation and manipulation of exceptions. *) @@ -28,3 +29,4 @@ and t_exception = { mutable ex_code : string option ; } + diff --git a/ocamldoc/odoc_global.ml b/ocamldoc/odoc_global.ml index c516242a..de5fdd8b 100644 --- a/ocamldoc/odoc_global.ml +++ b/ocamldoc/odoc_global.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_global.ml,v 1.3 2003/11/24 10:41:03 starynke Exp $ *) (** Global variables. *) diff --git a/ocamldoc/odoc_global.mli b/ocamldoc/odoc_global.mli index 30158f95..1c8c2194 100644 --- a/ocamldoc/odoc_global.mli +++ b/ocamldoc/odoc_global.mli @@ -9,6 +9,8 @@ (* *) (***********************************************************************) +(* $Id: odoc_global.mli,v 1.2 2003/11/24 10:41:03 starynke Exp $ *) + (** Global variables. *) (** A counter for errors. *) diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 164b8b14..71ba1fc6 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -9,6 +9,7 @@ (* *) (***********************************************************************) +(* $Id: odoc_html.ml,v 1.52.4.1 2004/06/25 13:39:16 guesdon Exp $ *) (** Generation of html documentation. *) @@ -80,8 +81,6 @@ module Naming = (** Return the complete link target for the given exception. *) let complete_exception_target e = complete_target mark_exception e.ex_name - - (** Return the link target for the given value. *) let value_target v = target mark_value (Name.simple v.val_name) @@ -157,6 +156,12 @@ module Naming = let f = type_prefix^name^".html" in f + (** Return the complete filename for the code of the + given module name. *) + let file_code_module_complete_target name = + let f = code_prefix^name^".html" in + f + (** Return the complete filename for the code of the type of the given class or class type name. *) let file_type_class_complete_target name = @@ -164,16 +169,22 @@ module Naming = f end +module StringSet = Set.Make (struct type t = string let compare = compare end) + (** A class with a method to colorize a string which represents OCaml code. *) class ocaml_code = object(self) - method html_of_code ?(with_pre=true) code = - let html_code = Odoc_ocamlhtml.html_of_code ~with_pre: with_pre code in - html_code + method html_of_code b ?(with_pre=true) code = + Odoc_ocamlhtml.html_of_code b ~with_pre: with_pre code end +let new_buf () = Buffer.create 1024 +let bp = Printf.bprintf +let bs = Buffer.add_string + + (** Generation of html code from text structures. *) -class text = +class virtual text = object (self) (** We want to display colorized code. *) inherit ocaml_code @@ -182,7 +193,6 @@ class text = make some replacements (double newlines replaced by
). *) method escape s = Odoc_ocamlhtml.escape_base s - method keep_alpha_num s = let len = String.length s in let buf = Buffer.create len in @@ -208,93 +218,156 @@ class text = Some s -> s | None -> Printf.sprintf "%d_%s" n (self#label_of_text t) - (** Return the html code corresponding to the [text] parameter. *) - method html_of_text t = String.concat "" (List.map self#html_of_text_element t) + (** Print the html code corresponding to the [text] parameter. *) + method html_of_text b t = + List.iter (self#html_of_text_element b) t - (** Return the html code for the [text_element] in parameter. *) - method html_of_text_element te = + (** Print the html code for the [text_element] in parameter. *) + method html_of_text_element b te = print_DEBUG "text::html_of_text_element"; match te with - | Odoc_info.Raw s -> self#html_of_Raw s - | Odoc_info.Code s -> self#html_of_Code s - | Odoc_info.CodePre s -> self#html_of_CodePre s - | Odoc_info.Verbatim s -> self#html_of_Verbatim s - | Odoc_info.Bold t -> self#html_of_Bold t - | Odoc_info.Italic t -> self#html_of_Italic t - | Odoc_info.Emphasize t -> self#html_of_Emphasize t - | Odoc_info.Center t -> self#html_of_Center t - | Odoc_info.Left t -> self#html_of_Left t - | Odoc_info.Right t -> self#html_of_Right t - | Odoc_info.List tl -> self#html_of_List tl - | Odoc_info.Enum tl -> self#html_of_Enum tl - | Odoc_info.Newline -> self#html_of_Newline - | Odoc_info.Block t -> self#html_of_Block t - | Odoc_info.Title (n, l_opt, t) -> self#html_of_Title n l_opt t - | Odoc_info.Latex s -> self#html_of_Latex s - | Odoc_info.Link (s, t) -> self#html_of_Link s t - | Odoc_info.Ref (name, ref_opt) -> self#html_of_Ref name ref_opt - | Odoc_info.Superscript t -> self#html_of_Superscript t - | Odoc_info.Subscript t -> self#html_of_Subscript t - - method html_of_Raw s = self#escape s - - method html_of_Code s = + | Odoc_info.Raw s -> self#html_of_Raw b s + | Odoc_info.Code s -> self#html_of_Code b s + | Odoc_info.CodePre s -> self#html_of_CodePre b s + | Odoc_info.Verbatim s -> self#html_of_Verbatim b s + | Odoc_info.Bold t -> self#html_of_Bold b t + | Odoc_info.Italic t -> self#html_of_Italic b t + | Odoc_info.Emphasize t -> self#html_of_Emphasize b t + | Odoc_info.Center t -> self#html_of_Center b t + | Odoc_info.Left t -> self#html_of_Left b t + | Odoc_info.Right t -> self#html_of_Right b t + | Odoc_info.List tl -> self#html_of_List b tl + | Odoc_info.Enum tl -> self#html_of_Enum b tl + | Odoc_info.Newline -> self#html_of_Newline b + | Odoc_info.Block t -> self#html_of_Block b t + | Odoc_info.Title (n, l_opt, t) -> self#html_of_Title b n l_opt t + | Odoc_info.Latex s -> self#html_of_Latex b s + | Odoc_info.Link (s, t) -> self#html_of_Link b s t + | Odoc_info.Ref (name, ref_opt) -> self#html_of_Ref b name ref_opt + | Odoc_info.Superscript t -> self#html_of_Superscript b t + | Odoc_info.Subscript t -> self#html_of_Subscript b t + | Odoc_info.Module_list l -> self#html_of_Module_list b l + | Odoc_info.Index_list -> self#html_of_Index_list b + + method html_of_Raw b s = bs b (self#escape s) + + method html_of_Code b s = if !Args.colorize_code then - self#html_of_code ~with_pre: false s + self#html_of_code b ~with_pre: false s else - ""^(self#escape s)^"" - - method html_of_CodePre s = + ( + bs b ""; + bs b (self#escape s); + bs b "" + ) + + method html_of_CodePre b s = if !Args.colorize_code then - "
"^(self#html_of_code s)^"
"
+	(
+         bs b "
";
+	 self#html_of_code b s;
+	 bs b "
"
+	)
       else
-        "
"^(self#escape s)^"
"
-
-    method html_of_Verbatim s = "
"^(self#escape s)^"
"
-    method html_of_Bold t = ""^(self#html_of_text t)^""
-    method html_of_Italic t = ""^(self#html_of_text t)^""
-    method html_of_Emphasize t = ""^(self#html_of_text t)^""
-    method html_of_Center t = "
"^(self#html_of_text t)^"
"
-    method html_of_Left t = "
"^(self#html_of_text t)^"
"
-    method html_of_Right t = "
"^(self#html_of_text t)^"
"
-
-    method html_of_List tl = 
-      "
    \n"^
-      (String.concat ""
-         (List.map (fun t -> "
  • "^(self#html_of_text t)^"
    • \n") tl))^
-      "
\n"
-
-    method html_of_Enum tl =
-      "
    \n"^
-      (String.concat ""
-         (List.map (fun t -> "
  1. "^(self#html_of_text t)^"
    2. \n") tl))^
-      "
\n"
-
-    method html_of_Newline = "\n
\n"
-
-    method html_of_Block t =
-      "
\n"^(self#html_of_text t)^"
\n"
-
-    method html_of_Title n label_opt t =
-      let css_class = "title"^(string_of_int n) in
+        (
+	 bs b "
" ;
+	 bs b (self#escape s);
+	 bs b "
"
+	)
+
+    method html_of_Verbatim b s = 
+      bs b "
";
+      bs b (self#escape s);
+      bs b "
"
+
+    method html_of_Bold b t = 
+      bs b "";
+      self#html_of_text b t;
+      bs b ""
+
+    method html_of_Italic b t = 
+      bs b "" ;
+      self#html_of_text b t;
+      bs b ""
+
+    method html_of_Emphasize b t = 
+      bs b "" ;
+      self#html_of_text b t ;
+      bs b ""
+
+    method html_of_Center b t = 
+      bs b "
";
+      self#html_of_text b t;
+      bs b "
"
+
+    method html_of_Left b t = 
+      bs b "
";
+      self#html_of_text b t;
+      bs b "
"
+
+    method html_of_Right b t = 
+      bs b "
";
+      self#html_of_text b t;
+      bs b "
"
+
+    method html_of_List b tl = 
+      bs b "
    \n";
+      List.iter 
+	(fun t -> bs b "
  • "; self#html_of_text b t; bs b "
    • \n")
+	tl;
+      bs b "
\n"
+
+    method html_of_Enum b tl =
+      bs b "
    \n";
+      List.iter 
+	(fun t -> bs b "
  1. "; self#html_of_text b t; bs b"
    2. \n") 
+	tl;
+      bs b "
\n"
+
+    method html_of_Newline b = bs b "\n
\n"
+
+    method html_of_Block b t =
+      bs b "
\n";
+      self#html_of_text b t;
+      bs b "
\n"
+
+    method html_of_Title b n label_opt t =
       let label1 = self#create_title_label (n, label_opt, t) in
-      "
\n"^
-      "\n"^
-      "\n"^
-      "\n\n
\n"^
-      ""^(self#html_of_text t)^"\n"^
-      "
\n
\n"
-
-    method html_of_Latex _ = ""
+      bs b "\n";
+      let (tag_o, tag_c) = 
+	if n > 6 then
+	  (Printf.sprintf "div class=\"h%d\"" n, "div")
+	else
+	  let t = Printf.sprintf "h%d" n in (t, t)
+      in
+      bs b "<";
+      bs b tag_o;
+      bs b ">";
+      self#html_of_text b t;
+      bs b ""
+
+    method html_of_Latex b _ = ()
       (* don't care about LaTeX stuff in HTML. *)
 
-    method html_of_Link s t =
-      ""^(self#html_of_text t)^""
+    method html_of_Link b s t =
+      bs b "";
+      self#html_of_text b t;
+      bs b ""
 
-    method html_of_Ref name ref_opt =
+    method html_of_Ref b name ref_opt =
       match ref_opt with
         None -> 
-          self#html_of_text_element (Odoc_info.Code name)
+          self#html_of_text_element b (Odoc_info.Code name)
       | Some kind ->
 	  let h name = Odoc_info.Code (Odoc_info.use_hidden_modules name) in
           let (target, text) = 
@@ -313,15 +386,78 @@ class text =
             | Odoc_info.RK_section t -> (Naming.complete_label_target name,
 					 Odoc_info.Italic [Raw (Odoc_info.string_of_text t)])
           in
-          ""^
-          (self#html_of_text_element text)^
-	  ""
-
-    method html_of_Superscript t =
-      ""^(self#html_of_text t)^""
+          bs b ("");
+          self#html_of_text_element b text;
+	  bs b ""
+
+    method html_of_Superscript b t =
+      bs b "";
+      self#html_of_text b t;
+      bs b ""
+
+    method html_of_Subscript b t =
+      bs b "";
+      self#html_of_text b t;
+      bs b ""
+
+    method html_of_Module_list b l =
+      bs b "
\n\n";
+      List.iter
+        (fun name ->
+	  bs b "" html m.m_name;
+	     bs b "\n"
+	)
+        l;
+      bs b "
";
+	  (
+	   try
+	     let m = 
+	       List.find (fun m -> m.m_name = name) self#list_modules 
+	     in
+	     let (html, _) = Naming.html_files m.m_name in
+	     bp b "%s";
+	     self#html_of_info_first_sentence b m.m_info;
+	   with
+	     Not_found ->
+	       Odoc_messages.pwarning (Odoc_messages.cross_module_not_found name);
+	       bp b "%s" name
+	  );
+	  bs b "
\n\n";
 
-    method html_of_Subscript t =
-      ""^(self#html_of_text t)^""
+    method html_of_Index_list b =
+      let index_if_not_empty l url m =
+        match l with
+          [] -> ()
+        | _ -> bp b "%s
\n" url m
+      in
+      index_if_not_empty self#list_types self#index_types Odoc_messages.index_of_types;
+      index_if_not_empty self#list_exceptions self#index_exceptions Odoc_messages.index_of_exceptions;
+      index_if_not_empty self#list_values self#index_values Odoc_messages.index_of_values;
+      index_if_not_empty self#list_attributes self#index_attributes Odoc_messages.index_of_attributes;
+      index_if_not_empty self#list_methods self#index_methods Odoc_messages.index_of_methods;
+      index_if_not_empty self#list_classes self#index_classes Odoc_messages.index_of_classes;
+      index_if_not_empty self#list_class_types self#index_class_types Odoc_messages.index_of_class_types;
+      index_if_not_empty self#list_modules self#index_modules Odoc_messages.index_of_modules;
+      index_if_not_empty self#list_module_types self#index_module_types Odoc_messages.index_of_module_types
+
+    method virtual list_types : Odoc_info.Type.t_type list
+    method virtual index_types : string
+    method virtual list_exceptions : Odoc_info.Exception.t_exception list
+    method virtual index_exceptions : string
+    method virtual list_values : Odoc_info.Value.t_value list
+    method virtual index_values : string
+    method virtual list_attributes : Odoc_info.Value.t_attribute list
+    method virtual index_attributes : string
+    method virtual list_methods : Odoc_info.Value.t_method list
+    method virtual index_methods : string
+    method virtual list_classes : Odoc_info.Class.t_class list
+    method virtual index_classes : string
+    method virtual list_class_types : Odoc_info.Class.t_class_type list
+    method virtual index_class_types : string
+    method virtual list_modules : Odoc_info.Module.t_module list
+    method virtual index_modules : string
+    method virtual list_module_types : Odoc_info.Module.t_module_type list
+    method virtual index_module_types : string
 
   end
 
@@ -334,137 +470,161 @@ class virtual info =
     val mutable tag_functions = ([] : (string * (Odoc_info.text -> string)) list)
 
     (** The method used to get html code from a [text]. *)
-    method virtual html_of_text : Odoc_info.text -> string
+    method virtual html_of_text : Buffer.t -> Odoc_info.text -> unit
 
-    (** Return html for an author list. *)
-    method html_of_author_list l =
+    (** Print html for an author list. *)
+    method html_of_author_list b l =
       match l with
-        [] ->
-          ""
+        [] -> ()
       | _ ->
-          ""^Odoc_messages.authors^": "^
-          (String.concat ", " l)^
-          "
\n"
+          bp b "%s: %s
\n"
+	    Odoc_messages.authors
+            (String.concat ", " l)
 
-    (** Return html code for the given optional version information.*)
-    method html_of_version_opt v_opt =
+    (** Print html code for the given optional version information.*)
+    method html_of_version_opt b v_opt =
       match v_opt with
-        None -> ""
-      | Some v -> ""^Odoc_messages.version^": "^v^"
\n"
+        None -> ()
+      | Some v -> 
+	   bp b "%s: %s
\n" Odoc_messages.version v
 
-    (** Return html code for the given optional since information.*)
-    method html_of_since_opt s_opt =
+    (** Print html code for the given optional since information.*)
+    method html_of_since_opt b s_opt =
       match s_opt with
-        None -> ""
-      | Some s -> ""^Odoc_messages.since^" "^s^"
\n"
+        None -> ()
+      | Some s -> 
+	  bp b "%s %s
\n" Odoc_messages.since s
 
-    (** Return html code for the given list of raised exceptions.*)
-    method html_of_raised_exceptions l =
+    (** Print html code for the given list of raised exceptions.*)
+    method html_of_raised_exceptions b l =
       match l with
-        [] -> ""
-      | (s, t) :: [] -> ""^Odoc_messages.raises^" "^s^" "^(self#html_of_text t)^"
\n"
+        [] -> ()
+      | (s, t) :: [] -> 
+	  bp b "%s %s "
+	    Odoc_messages.raises
+	    s;
+	  self#html_of_text b t;
+	  bs b "
\n"
       | _ ->
-          ""^Odoc_messages.raises^"
    "^
-          (String.concat ""
-             (List.map
-                (fun (ex, desc) -> "
  • "^ex^" "^(self#html_of_text desc)^"
    • \n")
-                l
-             )
-          )^"
\n"
-
-    (** Return html code for the given "see also" reference. *)
-    method html_of_see (see_ref, t)  =
+          bp b "%s
    " Odoc_messages.raises;
+	  List.iter
+            (fun (ex, desc) -> 
+	      bp b "
  • %s " ex ;
+	      self#html_of_text b desc;
+	      bs b "
    • \n"
+	    )
+            l;
+          bs b "
\n"
+
+    (** Print html code for the given "see also" reference. *)
+    method html_of_see b (see_ref, t)  =
       let t_ref = 
         match see_ref with
           Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ]
         | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t
         | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t
       in
-      self#html_of_text t_ref
+      self#html_of_text b t_ref
 
-    (** Return html code for the given list of "see also" references.*)
-    method html_of_sees l =
+    (** Print html code for the given list of "see also" references.*)
+    method html_of_sees b l =
       match l with
-        [] -> ""
-      | see :: [] -> ""^Odoc_messages.see_also^" "^(self#html_of_see see)^"
\n"
+        [] -> ()
+      | see :: [] -> 
+	  bp b "%s " Odoc_messages.see_also;
+	  self#html_of_see b see;
+	  bs b "
\n"
       | _ ->
-          ""^Odoc_messages.see_also^"
    "^
-          (String.concat ""
-             (List.map
-                (fun see -> "
  • "^(self#html_of_see see)^"
    • \n")
-                l
-             )
-          )^"
\n"
-
-    (** Return html code for the given optional return information.*)
-    method html_of_return_opt return_opt =
+          bp b "%s
    " Odoc_messages.see_also;
+          List.iter
+            (fun see -> 
+	      bs b "
  • " ;
+	      self#html_of_see b see;
+	      bs b "
    • \n"
+	    )
+            l;
+          bs b "
\n"
+
+    (** Print html code for the given optional return information.*)
+    method html_of_return_opt b return_opt =
       match return_opt with
-        None -> ""
-      | Some s -> ""^Odoc_messages.returns^" "^(self#html_of_text s)^"
\n"
+        None -> ()
+      | Some s -> 
+	  bp b "%s " Odoc_messages.returns;
+	  self#html_of_text b s;
+	  bs b "
\n" 
 
-    (** Return html code for the given list of custom tagged texts. *)
-    method html_of_custom l =
-      let buf = Buffer.create 50 in
+    (** Print html code for the given list of custom tagged texts. *)
+    method html_of_custom b l =
       List.iter
         (fun (tag, text) ->
           try
             let f = List.assoc tag tag_functions in
-            Buffer.add_string buf (f text)
+            Buffer.add_string b (f text)
           with
             Not_found ->
               Odoc_info.warning (Odoc_messages.tag_not_handled tag)
         )
-        l;
-      Buffer.contents buf
+        l
 
-    (** Return html code for a description, except for the [i_params] field. *)
-    method html_of_info info_opt =
+    (** Print html code for a description, except for the [i_params] field. 
+       @param indent can be specified not to use the style of info comments;
+       default is [true].
+    *)
+    method html_of_info ?(indent=true) b info_opt =
       match info_opt with
         None ->
-          ""
+          ()
       | Some info ->
           let module M = Odoc_info in
-          "
\n"^
-          (match info.M.i_deprecated with
-            None -> ""
-          | Some d -> 
-              ""^Odoc_messages.deprecated^" "^
-              (self#html_of_text d)^
-              "
\n"
-          )^
-          (match info.M.i_desc with
-            None -> "" 
-          | Some d when d = [Odoc_info.Raw ""] -> ""
-          | Some d -> (self#html_of_text d)^"
\n"
-          )^
-          (self#html_of_author_list info.M.i_authors)^
-          (self#html_of_version_opt info.M.i_version)^
-          (self#html_of_since_opt info.M.i_since)^
-          (self#html_of_raised_exceptions info.M.i_raised_exceptions)^
-          (self#html_of_return_opt info.M.i_return_value)^
-          (self#html_of_sees info.M.i_sees)^
-          (self#html_of_custom info.M.i_custom)^
-          "
\n"
-
-    (** Return html code for the first sentence of a description. 
+          if indent then bs b "
\n";
+          (
+	   match info.M.i_deprecated with
+            None -> ()
+           | Some d -> 
+               bs b "";
+	       bs b Odoc_messages.deprecated ;
+	       bs b "" ;
+	       self#html_of_text b d;
+               bs b "
\n" 
+          );
+          (
+	   match info.M.i_desc with
+             None -> ()
+           | Some d when d = [Odoc_info.Raw ""] -> ()
+           | Some d -> self#html_of_text b d; bs b "
\n"
+          );
+          self#html_of_author_list b info.M.i_authors;
+          self#html_of_version_opt b info.M.i_version;
+          self#html_of_since_opt b info.M.i_since;
+          self#html_of_raised_exceptions b info.M.i_raised_exceptions;
+          self#html_of_return_opt b info.M.i_return_value;
+          self#html_of_sees b info.M.i_sees;
+          self#html_of_custom b info.M.i_custom;
+          if indent then bs b "
\n"
+
+    (** Print html code for the first sentence of a description. 
        The titles and lists in this first sentence has been removed.*)
-    method html_of_info_first_sentence info_opt =
+    method html_of_info_first_sentence b info_opt =
       match info_opt with
-        None -> ""
+        None -> ()
       | Some info ->
           let module M = Odoc_info in
           let dep = info.M.i_deprecated <> None in
-          "
\n"^
-          (if dep then "" else "") ^
-          (match info.M.i_desc with
-            None -> "" 
-          | Some d when d = [Odoc_info.Raw ""] -> ""
-          | Some d -> (self#html_of_text
-                         (Odoc_info.text_no_title_no_list
-                            (Odoc_info.first_sentence_of_text d)))^"\n"
-          )^
-          (if dep then "" else "") ^
-          "
\n"
+          bs b "
\n";
+          if dep then bs b "";
+          (
+	   match info.M.i_desc with
+             None -> ()
+           | Some d when d = [Odoc_info.Raw ""] -> ()
+           | Some d -> 
+	       self#html_of_text b
+                 (Odoc_info.text_no_title_no_list
+                    (Odoc_info.first_sentence_of_text d));
+	       bs b "\n"
+          );
+          if dep then bs b "";
+          bs b "
\n"
 
   end
 
@@ -472,6 +632,36 @@ class virtual info =
 
 let opt = Odoc_info.apply_opt
 
+let print_concat b sep f =
+  let rec iter = function
+      [] -> ()
+    | [c] -> f c
+    | c :: q ->
+	f c;
+	bs b sep;
+	iter q
+  in
+  iter
+
+let newline_to_indented_br s =
+  let len = String.length s in
+  let b = Buffer.create len in
+  for i = 0 to len - 1 do
+    match s.[i] with
+      '\n' -> Buffer.add_string b "
     "
+    | c -> Buffer.add_char b c
+  done;
+  Buffer.contents b
+
+let remove_last_newline s =
+  let len = String.length s in
+  if len <= 0 then
+    s
+  else
+    match s.[len-1] with
+      '\n' -> String.sub s 0 (len-1)
+    | _ -> s
+
 (** This class is used to create objects which can generate a simple html documentation. *)
 class html =
   object (self)
@@ -495,12 +685,48 @@ class html =
         ".warning { color : Red ; font-weight : bold }" ;
         ".info { margin-left : 3em; margin-right : 3em }" ;
         ".code { color : #465F91 ; }" ;
-        ".title1 { font-size : 20pt ; background-color : #909DFF }" ;
-        ".title2 { font-size : 20pt ; background-color : #90BDFF }" ;
-        ".title3 { font-size : 20pt ; background-color : #90DDFF }" ;
-        ".title4 { font-size : 20pt ; background-color : #90EDFF }" ;
-        ".title5 { font-size : 20pt ; background-color : #90FDFF }" ;
-        ".title6 { font-size : 20pt ; background-color : #C0FFFF }" ;
+        "h1 { font-size : 20pt ; text-align: center; }" ;
+
+	"h2 { font-size : 20pt ; border: 1px solid #000000; "^
+	"margin-top: 5px; margin-bottom: 2px;"^
+	"text-align: center; background-color: #90BDFF ;"^
+	"padding: 2px; }" ;
+
+	"h3 { font-size : 20pt ; border: 1px solid #000000; "^
+	"margin-top: 5px; margin-bottom: 2px;"^
+	"text-align: center; background-color: #90DDFF ;"^
+	"padding: 2px; }" ;
+
+	"h4 { font-size : 20pt ; border: 1px solid #000000; "^
+	"margin-top: 5px; margin-bottom: 2px;"^
+	"text-align: center; background-color: #90EDFF ;"^
+	"padding: 2px; }" ;
+
+	"h5 { font-size : 20pt ; border: 1px solid #000000; "^
+	"margin-top: 5px; margin-bottom: 2px;"^
+	"text-align: center; background-color: #90FDFF ;"^
+	"padding: 2px; }" ;
+
+	"h6 { font-size : 20pt ; border: 1px solid #000000; "^
+	"margin-top: 5px; margin-bottom: 2px;"^
+	"text-align: center; background-color: #C0FFFF ; "^
+	"padding: 2px; }" ;
+
+	"div.h7 { font-size : 20pt ; border: 1px solid #000000; "^
+	"margin-top: 5px; margin-bottom: 2px;"^
+	"text-align: center; background-color: #E0FFFF ; "^
+	"padding: 2px; }" ;
+
+	"div.h8 { font-size : 20pt ; border: 1px solid #000000; "^
+	"margin-top: 5px; margin-bottom: 2px;"^
+	"text-align: center; background-color: #F0FFFF ; "^
+	"padding: 2px; }" ;
+
+	"div.h9 { font-size : 20pt ; border: 1px solid #000000; "^
+	"margin-top: 5px; margin-bottom: 2px;"^
+	"text-align: center; background-color: #FFFFFF ; "^
+	"padding: 2px; }" ;
+
 	".typetable { border-style : hidden }" ;
 	".indextable { border-style : hidden }" ;
 	".paramstable { border-style : hidden ; padding: 5pt 5pt}" ;
@@ -508,6 +734,8 @@ class html =
         "tr { background-color : White }" ;
 	"td.typefieldcomment { background-color : #FFFFFF }" ;
 	"pre { margin-bottom: 4px }" ;
+
+	"div.sig_block {margin-left: 2em}" ;
       ] 
       
     (** The style file for all pages. *)
@@ -519,61 +747,70 @@ class html =
     (** The known types names. 
        Used to know if we must create a link to a type
        when printing a type. *)
-    val mutable known_types_names = []
+    val mutable known_types_names = StringSet.empty
 
     (** The known class and class type names. 
        Used to know if we must create a link to a class 
        or class type or not when printing a type. *)
-    val mutable known_classes_names = []
+    val mutable known_classes_names = StringSet.empty
 
     (** The known modules and module types names. 
        Used to know if we must create a link to a type or not
        when printing a module type. *)
-    val mutable known_modules_names = []
+    val mutable known_modules_names = StringSet.empty
 
     (** The main file. *)
-    val mutable index = "index.html"
+    method index = "index.html"
     (** The file for the index of values. *)
-    val mutable index_values = "index_values.html"
+    method index_values = "index_values.html"
     (** The file for the index of types. *)
-    val mutable index_types = "index_types.html"
+    method index_types = "index_types.html"
     (** The file for the index of exceptions. *)
-    val mutable index_exceptions = "index_exceptions.html"
+    method index_exceptions = "index_exceptions.html"
     (** The file for the index of attributes. *)
-    val mutable index_attributes = "index_attributes.html"
+    method index_attributes = "index_attributes.html"
     (** The file for the index of methods. *)
-    val mutable index_methods = "index_methods.html"
+    method index_methods = "index_methods.html"
     (** The file for the index of classes. *)
-    val mutable index_classes = "index_classes.html"
+    method index_classes = "index_classes.html"
     (** The file for the index of class types. *)
-    val mutable index_class_types = "index_class_types.html"
+    method index_class_types = "index_class_types.html"
     (** The file for the index of modules. *)
-    val mutable index_modules = "index_modules.html"
+    method index_modules = "index_modules.html"
     (** The file for the index of module types. *)
-    val mutable index_module_types = "index_module_types.html"
+    method index_module_types = "index_module_types.html"
 
 
     (** The list of attributes. Filled in the [generate] method. *)
     val mutable list_attributes = []
+    method list_attributes = list_attributes
     (** The list of methods. Filled in the [generate] method. *)
     val mutable list_methods = []
+    method list_methods = list_methods
     (** The list of values. Filled in the [generate] method. *)
     val mutable list_values = []
+    method list_values = list_values
     (** The list of exceptions. Filled in the [generate] method. *)
     val mutable list_exceptions = []
+    method list_exceptions = list_exceptions
     (** The list of types. Filled in the [generate] method. *)
     val mutable list_types = []
+    method list_types = list_types
     (** The list of modules. Filled in the [generate] method. *)
     val mutable list_modules = []
+    method list_modules = list_modules
     (** The list of module types. Filled in the [generate] method. *)
     val mutable list_module_types = []
+    method list_module_types = list_module_types
     (** The list of classes. Filled in the [generate] method. *)
     val mutable list_classes = []
+    method list_classes = list_classes
     (** The list of class types. Filled in the [generate] method. *)
     val mutable list_class_types = []
+    method list_class_types = list_class_types
 
     (** The header of pages. Must be prepared by the [prepare_header] method.*)
-    val mutable header = fun ?(nav=None) -> fun ?(comments=[]) -> fun _ -> ""
+    val mutable header = fun b -> fun ?(nav=None) -> fun ?(comments=[]) -> fun _ -> ()
 
     (** Init the style. *)
     method init_style =
@@ -612,67 +849,69 @@ class html =
       (self#escape s)
 
     (** Get the page header. *)
-    method header ?nav ?comments title = header ?nav ?comments title
+    method print_header b ?nav ?comments title = header b ?nav ?comments title
 
     (** A function to build the header of pages. *)
     method prepare_header module_list =
-      let f ?(nav=None) ?(comments=[]) t  = 
+      let f b ?(nav=None) ?(comments=[]) t  = 
         let link_if_not_empty l m url =
           match l with
-            [] -> ""
-          | _ -> "\n"
+            [] -> ()
+          | _ -> 
+	      bp b "\n" m url
         in
-        "\n"^
-        style^
-        "\n"^
+        bs b "\n";
+	bs b style;
+        bs b "\n" ;
         (
          match nav with
-           None -> ""
+           None -> ()
          | Some (pre_opt, post_opt, name) ->
              (match pre_opt with
-               None -> ""
+               None -> ()
              | Some name -> 
-                 "\n"
-             )^
+                 bp b "\n"
+		   (fst (Naming.html_files name));
+             );
              (match post_opt with
-               None -> ""
+               None -> ()
              | Some name -> 
-                 "\n"
-             )^
+                 bp b "\n"
+		   (fst (Naming.html_files name));
+             );
              (
               let father = Name.father name in
-              let href = if father = "" then index else fst (Naming.html_files father) in
-              "\n"
+              let href = if father = "" then self#index else fst (Naming.html_files father) in
+              bp b "\n" href
              )
-        )^
-        (link_if_not_empty list_types Odoc_messages.index_of_types index_types)^
-        (link_if_not_empty list_exceptions Odoc_messages.index_of_exceptions index_exceptions)^
-        (link_if_not_empty list_values Odoc_messages.index_of_values index_values)^
-        (link_if_not_empty list_attributes Odoc_messages.index_of_attributes index_attributes)^
-        (link_if_not_empty list_methods Odoc_messages.index_of_methods index_methods)^
-        (link_if_not_empty list_classes Odoc_messages.index_of_classes index_classes)^
-        (link_if_not_empty list_class_types Odoc_messages.index_of_class_types index_class_types)^
-        (link_if_not_empty list_modules Odoc_messages.index_of_modules index_modules)^
-        (link_if_not_empty list_module_types Odoc_messages.index_of_module_types index_module_types)^
-        (String.concat "\n"
-           (List.map
-              (fun m -> 
-                let html_file = fst (Naming.html_files m.m_name) in
-                ""
-              )
-              module_list
-           )
-        )^
-        (self#html_sections_links comments)^
-        ""^
-        t^
-        "\n\n"
+        );
+        link_if_not_empty self#list_types Odoc_messages.index_of_types self#index_types;
+        link_if_not_empty self#list_exceptions Odoc_messages.index_of_exceptions self#index_exceptions;
+        link_if_not_empty self#list_values Odoc_messages.index_of_values self#index_values;
+        link_if_not_empty self#list_attributes Odoc_messages.index_of_attributes self#index_attributes;
+        link_if_not_empty self#list_methods Odoc_messages.index_of_methods self#index_methods;
+        link_if_not_empty self#list_classes Odoc_messages.index_of_classes self#index_classes;
+        link_if_not_empty self#list_class_types Odoc_messages.index_of_class_types self#index_class_types;
+        link_if_not_empty self#list_modules Odoc_messages.index_of_modules self#index_modules;
+        link_if_not_empty self#list_module_types Odoc_messages.index_of_module_types self#index_module_types;
+	let print_one m =
+	  let html_file = fst (Naming.html_files m.m_name) in
+          bp b ""
+	    m.m_name html_file
+        in
+	print_concat b "\n" print_one module_list;
+        self#html_sections_links b comments;
+        bs b "";
+	bs b t ;
+	bs b "\n\n"
       in
       header <- f
 
     (** Build the html code for the link tags in the header, defining section and
        subsections for the titles found in the given comments.*)
-    method html_sections_links comments =
+    method html_sections_links b comments =
       let titles = List.flatten (List.map Odoc_info.get_titles_in_text comments) in
       let levels = 
         let rec iter acc l =
@@ -699,42 +938,47 @@ class html =
       in
       let section_titles = titles_per_level section_level in
       let subsection_titles = titles_per_level subsection_level in
-      let create_lines s_rel titles =
-        List.map
+      let print_lines s_rel titles =
+        List.iter
           (fun (n,lopt,t) -> 
             let s = Odoc_info.string_of_text t in
             let label = self#create_title_label (n,lopt,t) in
-            Printf.sprintf "\n" s s_rel label)
+            bp b "\n" s s_rel label
+	  )
           titles
       in
-      let section_lines = create_lines "Section" section_titles in
-      let subsection_lines = create_lines "Subsection" subsection_titles in
-      String.concat "" (section_lines @ subsection_lines)
+      print_lines "Section" section_titles ;
+      print_lines "Subsection" subsection_titles 
+
 
     (** Html code for navigation bar. 
        @param pre optional name for optional previous module/class 
        @param post optional name for optional next module/class
        @param name name of current module/class *)
-    method navbar pre post name =
-      "
"^
-      (match pre with
-        None -> ""
-      | Some name -> 
-          ""^Odoc_messages.previous^"\n"
-      )^
-      " "^
+    method print_navbar b pre post name =
+      bs b "
";
+      (
+       match pre with
+         None -> ()
+       | Some name -> 
+           bp b "%s\n"
+	     (fst (Naming.html_files name))
+	     Odoc_messages.previous
+      );
+      bs b " ";
+      let father = Name.father name in
+      let href = if father = "" then self#index else fst (Naming.html_files father) in
+      bp b "%s\n" href Odoc_messages.up;
+      bs b " ";
       (
-       let father = Name.father name in
-       let href = if father = "" then index else fst (Naming.html_files father) in
-       ""^Odoc_messages.up^"\n"
-      )^
-      " "^
-      (match post with
-        None -> ""
-      | Some name -> 
-          ""^Odoc_messages.next^"\n"
-      )^
-      "
\n"
+       match post with
+         None -> ()
+       | Some name -> 
+           bp b "%s\n"
+	     (fst (Naming.html_files name))
+	     Odoc_messages.next
+      );
+      bs b "
\n"
 
     (** Return html code with the given string in the keyword style.*)
     method keyword s = 
@@ -747,10 +991,13 @@ class html =
     method private output_code in_title file code =
       try
         let chanout = open_out file in
-        let html_code = self#html_of_code code in
-        output_string chanout (""^(self#header (self#inner_title in_title))^"\n");
-        output_string chanout html_code;
-        output_string chanout "";
+	let b = new_buf () in
+        bs b "";
+	self#print_header b (self#inner_title in_title);
+	bs b"\n";
+        self#html_of_code b code;
+        bs b "";
+	Buffer.output_buffer chanout b;
         close_out chanout
       with
         Sys_error s -> 
@@ -769,12 +1016,12 @@ class html =
             match_s
             rel
         in
-        if List.mem match_s known_types_names then
+        if StringSet.mem match_s known_types_names then
            ""^
            s_final^
            ""
         else
-          if List.mem match_s known_classes_names then
+          if StringSet.mem match_s known_classes_names then
             let (html_file, _) = Naming.html_files match_s in
             ""^s_final^""
           else
@@ -792,11 +1039,17 @@ class html =
     method create_fully_qualified_module_idents_links m_name s =
       let f str_t = 
         let match_s = Str.matched_string str_t in
-        if List.mem match_s known_modules_names then
+	let rel = Name.get_relative m_name match_s in
+	let s_final = Odoc_info.apply_if_equal 
+            Odoc_info.use_hidden_modules 
+            match_s
+            rel
+        in
+        if StringSet.mem match_s known_modules_names then
           let (html_file, _) = Naming.html_files match_s in
-          ""^(Name.get_relative m_name match_s)^""
+          ""^s_final^""
         else
-          match_s
+          s_final
       in
       let s2 = Str.global_substitute
           (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)")
@@ -805,317 +1058,470 @@ class html =
       in
       s2
 
-    (** Return html code to display a [Types.type_expr]. *)
-    method html_of_type_expr m_name t =
-      let s = String.concat "\n"
-          (Str.split (Str.regexp "\n") (Odoc_info.string_of_type_expr t))
-      in
-      let s2 = Str.global_replace (Str.regexp "\n") "
       " s in
-      Printf.sprintf 
-	"%s"
-	(self#create_fully_qualified_idents_links m_name s2)
-
-    (** Return html code to display a [Types.class_type].*)
-    method html_of_class_type_expr m_name t =
-      let s = String.concat "\n"
-          (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type t))
-      in
-      let s2 = Str.global_replace (Str.regexp "\n") "
       " s in
-      ""^(self#create_fully_qualified_idents_links m_name s2)^""
+    (** Print html code to display a [Types.type_expr]. *)
+    method html_of_type_expr b m_name t =
+      let s = remove_last_newline (Odoc_info.string_of_type_expr t) in
+      let s2 = newline_to_indented_br s in
+      bs b "";
+      bs b (self#create_fully_qualified_idents_links m_name s2);
+      bs b ""
 
-    (** Return html code to display a [Types.type_expr list].*)
-    method html_of_type_expr_list m_name sep l =
+    (** Print html code to display a [Types.type_expr list]. *)
+    method html_of_type_expr_list ?par b m_name sep l =
       print_DEBUG "html#html_of_type_expr_list";
-      let s = Odoc_info.string_of_type_list sep l in
+      let s = Odoc_info.string_of_type_list ?par sep l in
       print_DEBUG "html#html_of_type_expr_list: 1";
-      let s2 = Str.global_replace (Str.regexp "\n") "
       " s in
+      let s2 = newline_to_indented_br s in
       print_DEBUG "html#html_of_type_expr_list: 2";
-      ""^(self#create_fully_qualified_idents_links m_name s2)^""
-
-    (** Return html code to display a list of type parameters for the given type.*)
-    method html_of_type_expr_param_list m_name t =
+      bs b "";
+      bs b (self#create_fully_qualified_idents_links m_name s2);
+      bs b ""
+
+    (** Print html code to display a [Types.type_expr list] as type parameters
+       of a class of class type. *)
+    method html_of_class_type_param_expr_list b m_name l =
+      let s = Odoc_info.string_of_class_type_param_list l in
+      let s2 = newline_to_indented_br s in
+      bs b "[";
+      bs b (self#create_fully_qualified_idents_links m_name s2);
+      bs b "]"
+
+    (** Print html code to display a list of type parameters for the given type.*)
+    method html_of_type_expr_param_list b m_name t =
       let s = Odoc_info.string_of_type_param_list t in
-      let s2 = Str.global_replace (Str.regexp "\n") "
       " s in
-      ""^(self#create_fully_qualified_idents_links m_name s2)^""
+      let s2 = newline_to_indented_br s in
+      bs b "";
+      bs b (self#create_fully_qualified_idents_links m_name s2);
+      bs b ""
+
+    (** Print html code to display a [Types.module_type]. *)
+    method html_of_module_type b ?code m_name t =
+      let s = remove_last_newline (Odoc_info.string_of_module_type ?code t) in
+      bs b "";
+      bs b (self#create_fully_qualified_module_idents_links m_name s);
+      bs b ""
+
+    (** Print html code to display the given module kind. *)
+    method html_of_module_kind b father ?modu kind =
+      match kind with
+	Module_struct eles ->
+	  self#html_of_text b [Code "sig"];
+	  (
+	   match modu with
+	     None -> 
+	       bs b "
";
+	       List.iter (self#html_of_module_element b father) eles;
+	       bs b "
"
+	   | Some m ->
+	       let (html_file, _) = Naming.html_files m.m_name in
+	       bp b " .. " html_file
+	  );
+	  self#html_of_text b [Code "end"]
+      | Module_alias a ->
+	  bs b "";
+	  bs b (self#create_fully_qualified_module_idents_links father a.ma_name);
+	  bs b ""
+      | Module_functor (p, k) ->
+	  bs b "
";
+	  self#html_of_module_parameter b father p;
+	  self#html_of_module_kind b father ?modu k;
+	  bs b "
"
+      | Module_apply (k1, k2) ->
+	  (* TODO: l'application n'est pas correcte dans un .mli. 
+	     Que faire ? -> afficher le module_type du typedtree  *)
+	  self#html_of_module_kind b father k1;
+	  self#html_of_text b [Code "("];
+	  self#html_of_module_kind b father k2;
+	  self#html_of_text b [Code ")"]
+      | Module_with (k, s) ->
+	  (* TODO: à modifier quand Module_with sera plus détaillé *)
+	  self#html_of_module_type_kind b father ?modu k;
+	  bs b " ";
+	  bs b (self#create_fully_qualified_module_idents_links father s);
+	  bs b ""
+      | Module_constraint (k, tk) ->
+	  (* TODO: on affiche quoi ? *)
+	  self#html_of_module_kind b father ?modu k
+
+    method html_of_module_parameter b father p =
+      self#html_of_text b
+	[
+	  Code "functor (";
+	  Code p.mp_name ;
+	  Code " : ";
+	] ;
+      self#html_of_module_type_kind b father p.mp_kind;
+      self#html_of_text b [ Code ") -> "]
+
+    method html_of_module_element b father ele =
+      match ele with
+        Element_module m ->
+          self#html_of_module b ~complete: false m
+      | Element_module_type mt ->
+          self#html_of_modtype b ~complete: false mt
+      | Element_included_module im ->
+          self#html_of_included_module b im
+      | Element_class c ->
+          self#html_of_class b ~complete: false c
+      | Element_class_type ct ->
+          self#html_of_class_type b ~complete: false ct
+      | Element_value v ->
+          self#html_of_value b v
+      | Element_exception e ->
+          self#html_of_exception b e
+      | Element_type t ->
+          self#html_of_type b t
+      | Element_module_comment text ->
+          self#html_of_module_comment b text
+
+    (** Print html code to display the given module type kind. *)
+    method html_of_module_type_kind b father ?modu ?mt kind =
+      match kind with
+	Module_type_struct eles ->
+	  self#html_of_text b [Code "sig"];
+	  (
+	   match mt with
+	     None ->
+	       (
+		match modu with
+		  None ->
+		    bs b "
";
+		    List.iter (self#html_of_module_element b father) eles;
+		    bs b "
"
+		| Some m ->
+		    let (html_file, _) = Naming.html_files m.m_name in
+		    bp b " .. " html_file
+	       )
+	   | Some mt ->
+	       let (html_file, _) = Naming.html_files mt.mt_name in
+	       bp b " .. " html_file
+	  );
+	  self#html_of_text b [Code "end"]
+      | Module_type_functor (p, k) ->
+	  self#html_of_module_parameter b father p;
+	  self#html_of_module_type_kind b father ?modu ?mt k
+      | Module_type_alias a ->
+	  bs b "";
+	  bs b (self#create_fully_qualified_module_idents_links father a.mta_name);
+	  bs b ""	  
+      | Module_type_with (k, s) ->
+	  self#html_of_module_type_kind b father ?modu ?mt k;
+	  bs b " ";
+	  bs b (self#create_fully_qualified_module_idents_links father s);
+	  bs b ""
+
+    (** Print html code to display the type of a module parameter.. *)
+    method html_of_module_parameter_type b m_name p =
+      self#html_of_module_type b m_name ~code: p.mp_type_code p.mp_type
 
-    (** Return html code to display a [Types.module_type]. *)
-    method html_of_module_type m_name t =
-      let s = String.concat "\n"
-          (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type t))
-      in
-      let s2 = Str.global_replace (Str.regexp "\n") "
       " s in
-      ""^(self#create_fully_qualified_module_idents_links m_name s2)^""
-        
     (** Generate a file containing the module type in the given file name. *)
     method output_module_type in_title file mtyp =
-      let s = String.concat "\n"
-          (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type ~complete: true mtyp))
-      in
+      let s = remove_last_newline (Odoc_info.string_of_module_type ~complete: true mtyp) in
       self#output_code in_title file s
 
     (** Generate a file containing the class type in the given file name. *)
     method output_class_type in_title file ctyp =
-      let s = String.concat "\n"
-          (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type ~complete: true ctyp))
-      in
+      let s = remove_last_newline(Odoc_info.string_of_class_type ~complete: true ctyp) in
       self#output_code in_title file s
 
-
-    (** Return html code for a value. *)
-    method html_of_value v =
+    (** Print html code for a value. *)
+    method html_of_value b v =
       Odoc_info.reset_type_names ();
-      "
"^(self#keyword "val")^" "^
+      bs b "
";
+      bs b (self#keyword "val");
+      bs b " ";
       (* html mark *)
-      ""^
-      (match v.val_code with 
-        None -> Name.simple v.val_name
-      | Some c -> 
-          let file = Naming.file_code_value_complete_target v in
-          self#output_code v.val_name (Filename.concat !Args.target_dir file) c;
-          ""^(Name.simple v.val_name)^""
-      )^" : "^
-      (self#html_of_type_expr (Name.father v.val_name) v.val_type)^"
"^
-      (self#html_of_info v.val_info)^
-      (if !Args.with_parameter_list then
-        self#html_of_parameter_list (Name.father v.val_name) v.val_parameters
-      else
-        self#html_of_described_parameter_list (Name.father v.val_name) v.val_parameters
+      bp b "" (Naming.value_target v);
+      (
+       match v.val_code with 
+         None -> bs b (Name.simple v.val_name)
+       | Some c -> 
+           let file = Naming.file_code_value_complete_target v in
+           self#output_code v.val_name (Filename.concat !Args.target_dir file) c;
+           bp b "%s" file (Name.simple v.val_name)
+      );
+      bs b " : ";
+      self#html_of_type_expr b (Name.father v.val_name) v.val_type;
+      bs b "
";
+      self#html_of_info b v.val_info;
+      (
+       if !Args.with_parameter_list then
+         self#html_of_parameter_list b (Name.father v.val_name) v.val_parameters
+       else
+         self#html_of_described_parameter_list b (Name.father v.val_name) v.val_parameters
       )
 
-    (** Return html code for an exception. *)
-    method html_of_exception e =
+    (** Print html code for an exception. *)
+    method html_of_exception b e =
       Odoc_info.reset_type_names ();
-      "
"^(self#keyword "exception")^" "^
+      bs b "
";
+      bs b (self#keyword "exception");
+      bs b " ";
       (* html mark *)
-      ""^
-      (Name.simple e.ex_name)^
-      (match e.ex_args with
-        [] -> ""
-      | _ -> 
-          " "^(self#keyword "of")^" "^
-          (self#html_of_type_expr_list (Name.father e.ex_name) " * " e.ex_args)
-      )^
-      (match e.ex_alias with
-        None -> ""
-      | Some ea -> " = "^
-          (
-           match ea.ea_ex with
-             None -> ea.ea_name
-           | Some e -> ""^e.ex_name^""
-          )
-      )^
-      "
\n"^
-      (self#html_of_info e.ex_info)
+      bp b "%s" 
+	(Naming.exception_target e)
+	(Name.simple e.ex_name);
+      (
+       match e.ex_args with
+         [] -> ()
+       | _ -> 
+           bs b (" "^(self#keyword "of")^" ");
+           self#html_of_type_expr_list 
+	     ~par: false b (Name.father e.ex_name) " * " e.ex_args
+      );
+      (
+       match e.ex_alias with
+         None -> ()
+       | Some ea -> 
+	   bs b " = ";
+           (
+            match ea.ea_ex with
+              None -> bs b ea.ea_name
+            | Some e -> 
+		bp b "%s" (Naming.complete_exception_target e) e.ex_name
+           )
+      );
+      bs b "
\n";
+      self#html_of_info b e.ex_info
 
-    (** Return html code for a type. *)
-    method html_of_type t =
+    (** Print html code for a type. *)
+    method html_of_type b t =
       Odoc_info.reset_type_names ();
       let father = Name.father t.ty_name in
-      (match t.ty_manifest, t.ty_kind with 
-	None, Type_abstract -> "
" 
-      |	None, Type_variant _ 
-      |	None, Type_record _ -> "
" 
-      | Some _, Type_abstract -> "
"
-      | Some _, Type_variant _
-      |	Some _, Type_record _ -> "
"
-      )^
-      (self#keyword "type")^" "^
+      bs b 
+	(match t.ty_manifest, t.ty_kind with 
+	  None, Type_abstract -> "
" 
+	| None, Type_variant _ 
+	| None, Type_record _ -> "
" 
+	| Some _, Type_abstract -> "
"
+	| Some _, Type_variant _
+	| Some _, Type_record _ -> "
"
+	);
+      bs b ((self#keyword "type")^" ");
       (* html mark *)
-      ""^
-      (self#html_of_type_expr_param_list father t)^
-      (match t.ty_parameters with [] -> "" | _ -> " ")^
-      (Name.simple t.ty_name)^" "^
-      (match t.ty_manifest with None -> "" | Some typ -> "= "^(self#html_of_type_expr father typ)^" ")^
+      bp b "" (Naming.type_target t);
+      self#html_of_type_expr_param_list b father t;
+      (match t.ty_parameters with [] -> () | _ -> bs b " ");
+      bs b ((Name.simple t.ty_name)^" ");
+      (
+       match t.ty_manifest with 
+	 None -> ()
+       | Some typ -> 
+	   bs b "= ";
+	   self#html_of_type_expr b father typ;
+	   bs b " "
+      );
       (match t.ty_kind with
-        Type_abstract -> "
"
+        Type_abstract -> bs b "
"
       | Type_variant (l, priv) ->
-          "= "^(if priv then "private" else "")^
-	  (match t.ty_manifest with None -> "" | Some _ -> "
")^
-          "\n"^ 
-          (String.concat "\n"
-             (List.map 
-                (fun constr ->
-                  "\n"^
-                  "\n"^
-                  "\n"^
-                  (match constr.vc_text with
-                    None -> ""
-                  | Some t ->
-                      ""^
-                      ""^
-                      ""
-                  )^
-                  "\n"
-                )
-                l
-             )
-          )^
-          "
\n"^
-                  ""^
-                  (self#keyword "|")^
-                  "\n"^
-                  ""^
-                  (self#constructor constr.vc_name)^
-                  (match constr.vc_args with
-                    [] -> "" 
-                  | l -> 
-                      " "^(self#keyword "of")^" "^
-                      (self#html_of_type_expr_list father " * " l)
-                  )^
-                  ""^
-                      ""^
-                      "(*"^
-                      ""^
-                      ""^
-                      (self#html_of_text t)^
-                      ""^
-                      ""^
-                      "*)"^
-                      "
\n"
+          bs b "= ";
+	  if priv then bs b "private" ;
+	  bs b 
+	    (
+	     match t.ty_manifest with 
+	       None -> "" 
+	     | Some _ -> "
"
+	    );
+          bs b "\n";
+	  let print_one constr =
+            bs b "\n\n\n";
+            (
+	     match constr.vc_text with
+               None -> ()
+             | Some t ->
+		 bs b "";
+		 bs b "";
+		 bs b "";
+            );
+            bs b "\n"
+	  in
+	  print_concat b "\n" print_one l;
+          bs b "
\n";
+            bs b "";
+	    bs b (self#keyword "|");
+            bs b "\n";
+            bs b "";
+	    bs b (self#constructor constr.vc_name);
+            (
+	     match constr.vc_args with
+               [] -> ()
+             | l -> 
+		 bs b (" " ^ (self#keyword "of") ^ " ");
+		 self#html_of_type_expr_list ~par: false b father " * " l;
+            );
+            bs b "";
+		 bs b "";
+		 bs b "(*";
+		 bs b "";
+		 bs b "" ;
+		 self#html_of_text b t;
+		 bs b "";
+		 bs b "";
+		 bs b "*)";
+		 bs b "
\n"
 
       | Type_record (l, priv) ->
-          "= "^(if priv then "private " else "")^"{"^
-	  (match t.ty_manifest with None -> "" | Some _ -> "
")^
-          "\n"^ 
-          (String.concat "\n"
-             (List.map 
-                (fun r ->
-                  "\n"^
-                  "\n"^
-                  "\n"^
-                  (match r.rf_text with
-                    None -> ""
-                  | Some t ->
-                      ""^
-                      ""^
-                      ""
-                  )^
-                  "\n"
-                )
-                l
-             )
-          )^
-          "
\n"^
-                  "  "^
-                  "\n"^
-                  ""^(if r.rf_mutable then self#keyword "mutable " else "")^
-                  r.rf_name^" : "^(self#html_of_type_expr father r.rf_type)^";"^
-                  ""^
-                      ""^
-                      "(*"^
-                      ""^
-                      ""^
-                      (self#html_of_text t)^
-                      ""^
-                      ""^
-                      "*)"^
-                      "
\n"^
-          "}\n"
-      )^"\n"^
-      (self#html_of_info t.ty_info)^
-      "\n"
-
-    (** Return html code for a class attribute. *)
-    method html_of_attribute a =
+          bs b "= ";
+	  if priv then bs b "private " ;
+	  bs b "{";
+	  bs b
+	    (
+	     match t.ty_manifest with 
+	       None -> "" 
+	     | Some _ -> "
"
+	    );
+          bs b "\n" ;
+	  let print_one r =
+            bs b "\n\n\n";
+            (
+	     match r.rf_text with
+               None -> ()
+             | Some t ->
+                 bs b "";
+                 bs b "";
+	    );
+            bs b "\n"
+	  in
+	  print_concat b "\n" print_one l;
+          bs b "
\n";
+            bs b "  ";
+            bs b "\n";
+            bs b "";
+	    if r.rf_mutable then bs b (self#keyword "mutable ") ;
+            bs b (r.rf_name ^ " : ") ;
+	    self#html_of_type_expr b father r.rf_type;
+            bs b ";";
+                 bs b "";
+                 bs b "(*";
+                 bs b "";
+                 bs b "";
+		 self#html_of_text b t;
+		 bs b "";
+                 bs b "";
+                 bs b "*)
\n}\n"
+      );
+      bs b "\n";
+      self#html_of_info b t.ty_info;
+      bs b "\n"
+
+    (** Print html code for a class attribute. *)
+    method html_of_attribute b a =
       let module_name = Name.father (Name.father a.att_value.val_name) in
-      "
"^(self#keyword "val")^" "^
+      bs b "
" ;
+      bs b (self#keyword "val");
+      bs b " ";
       (* html mark *)
-      ""^
-      (if a.att_mutable then (self#keyword Odoc_messages.mutab)^" " else "")^
-      (match a.att_value.val_code with 
-        None -> Name.simple a.att_value.val_name
-      | Some c -> 
-          let file = Naming.file_code_attribute_complete_target a in
-          self#output_code a.att_value.val_name (Filename.concat !Args.target_dir file) c;
-          ""^(Name.simple a.att_value.val_name)^""
-      )^" : "^
-      (self#html_of_type_expr module_name  a.att_value.val_type)^"
"^
-      (self#html_of_info a.att_value.val_info)
-
-    (** Return html code for a class method. *)
-    method html_of_method m =
+      bp b "" (Naming.attribute_target a);
+      (
+       if a.att_mutable then 
+	 bs b ((self#keyword Odoc_messages.mutab)^ " ")
+       else
+	 ()
+      );
+      (
+       match a.att_value.val_code with 
+         None -> bs b (Name.simple a.att_value.val_name)
+       | Some c -> 
+           let file = Naming.file_code_attribute_complete_target a in
+           self#output_code a.att_value.val_name (Filename.concat !Args.target_dir file) c;
+           bp b "%s" file (Name.simple a.att_value.val_name);
+      );
+      bs b " : ";
+      self#html_of_type_expr b module_name  a.att_value.val_type;
+      bs b "
";
+      self#html_of_info b a.att_value.val_info
+
+    (** Print html code for a class method. *)
+    method html_of_method b m =
       let module_name = Name.father (Name.father m.met_value.val_name) in
-      "
"^(self#keyword "method")^" "^
+      bs b "
";
+      bs b ((self#keyword "method")^" ");
       (* html mark *)
-      ""^
-      (if m.met_private then (self#keyword "private")^" " else "")^
-      (if m.met_virtual then (self#keyword "virtual")^" " else "")^
-      (match m.met_value.val_code with 
-        None -> Name.simple m.met_value.val_name
-      | Some c -> 
-          let file = Naming.file_code_method_complete_target m in
-          self#output_code m.met_value.val_name (Filename.concat !Args.target_dir file) c;
-          ""^(Name.simple m.met_value.val_name)^""
-      )^" : "^
-      (self#html_of_type_expr module_name m.met_value.val_type)^"
"^
-      (self#html_of_info m.met_value.val_info)^
-      (if !Args.with_parameter_list then
-        self#html_of_parameter_list module_name m.met_value.val_parameters
-      else
-        self#html_of_described_parameter_list module_name m.met_value.val_parameters
+      bp b "" (Naming.method_target m);
+      if m.met_private then bs b ((self#keyword "private")^" ");
+      if m.met_virtual then bs b ((self#keyword "virtual")^" ");
+      (
+       match m.met_value.val_code with 
+         None -> bs b  (Name.simple m.met_value.val_name)
+       | Some c -> 
+           let file = Naming.file_code_method_complete_target m in
+           self#output_code m.met_value.val_name (Filename.concat !Args.target_dir file) c;
+           bp b "%s" file (Name.simple m.met_value.val_name);
+      );
+      bs b " : ";
+      self#html_of_type_expr b module_name m.met_value.val_type;
+      bs b "
";
+      self#html_of_info b m.met_value.val_info;
+      (
+       if !Args.with_parameter_list then
+         self#html_of_parameter_list b 
+	   module_name m.met_value.val_parameters
+       else
+         self#html_of_described_parameter_list b 
+	   module_name m.met_value.val_parameters
       )
 
-    (** Return html code for the description of a function parameter. *)
-    method html_of_parameter_description p =
+    (** Print html code for the description of a function parameter. *)
+    method html_of_parameter_description b p =
       match Parameter.names p with
         [] ->
-          ""
+          ()
       | name :: [] ->
           (
            (* Only one name, no need for label for the description. *)
            match Parameter.desc_by_name p name with
-             None -> ""
-           | Some t -> self#html_of_text t
+             None -> ()
+           | Some t -> self#html_of_text b t
           )
       | l ->
           (*  A list of names, we display those with a description. *)
-          let l2 = List.filter (fun n -> (Parameter.desc_by_name p n) <> None) l in
-          String.concat "
\n"
-            (List.map
-               (fun n ->
-                 match Parameter.desc_by_name p n with
-                   None -> ""
-                 | Some t -> ""^n^" : "^(self#html_of_text t)
-               )
-               l2
-            )
-
-    (** Return html code for a list of parameters. *)
-    method html_of_parameter_list m_name l =
+          let l2 = List.filter
+	      (fun n -> (Parameter.desc_by_name p n) <> None) 
+	      l 
+	  in
+	  let print_one n =
+	    match Parameter.desc_by_name p n with
+              None -> ()
+            | Some t -> 
+		bs b "";
+		bs b n;
+		bs b " : ";
+		self#html_of_text b t
+	  in
+	  print_concat b "
\n" print_one l2
+
+    (** Print html code for a list of parameters. *)
+    method html_of_parameter_list b m_name l =
       match l with
-        [] ->
-          ""
+        [] -> ()
       | _ ->
-          "
"^
-          "\n"^
-          "\n"^
-          "\n"^
-          "\n"^
-          "\n"^
-          "
"^Odoc_messages.parameters^": \n"^
-          "\n"^ 
-             (*border=\"0\" cellpadding=\"5\" cellspacing=\"0\">\n"^*)
-          (String.concat ""
-             (List.map
-                (fun p ->
-                  "\n"^
-                  "\n"^
-                  "\n"^
-                  "\n"
-                )
-                l
-             )
-          )^"
\n"^
-                  (match Parameter.complete_name p with
-                    "" -> "?"
-                  | s -> s
-                  )^":"^(self#html_of_type_expr m_name (Parameter.typ p))^"
\n"^
-                  (self#html_of_parameter_description p)^"\n"^
-                  "
\n"^
-          "
\n"
-
-    (** Return html code for the parameters which have a name and description. *)
-    method html_of_described_parameter_list m_name l =
+          bs b "
";
+          bs b "\n";
+          bs b "\n\n" ;
+          bs b "\n\n
";
+	  bs b "";
+	  bs b Odoc_messages.parameters;
+	  bs b ": \n\n";
+	  let print_one p =
+            bs b "\n\n\n";
+            bs b "\n";
+	  in
+          List.iter print_one l;
+          bs b "
\n";
+            bs b 
+	      (
+	       match Parameter.complete_name p with
+		 "" -> "?"
+               | s -> s
+              );
+	    bs b ":";
+	    self#html_of_type_expr b m_name (Parameter.typ p);
+	    bs b "
\n";
+            self#html_of_parameter_description b p;
+	    bs b "\n
\n
\n"
+
+    (** Print html code for the parameters which have a name and description. *)
+    method html_of_described_parameter_list b m_name l =
       (* get the params which have a name, and at least one name described. *)
       let l2 = List.filter 
           (fun p -> 
@@ -1125,97 +1531,114 @@ class html =
           l
       in
       let f p =
-        "
"^(Parameter.complete_name p)^" : "^
-        (self#html_of_parameter_description p)^"
\n"
+        bs b "
";
+	bs b (Parameter.complete_name p);
+	bs b " : " ;
+        self#html_of_parameter_description b p;
+	bs b "
\n"
       in
       match l2 with
-        [] -> ""
-      | _ -> "
"^(String.concat "" (List.map f l2))
+        [] -> ()
+      | _ -> 
+	  bs b "
";
+	  List.iter f l2
 
-    (** Return html code for a list of module parameters. *)
-    method html_of_module_parameter_list m_name l =
+    (** Print html code for a list of module parameters. *)
+    method html_of_module_parameter_list b m_name l =
       match l with
         [] ->
-          ""
+          ()
       | _ ->
-          "\n"^
-          "\n"^
-          "\n"^
-          "\n"^
-          "\n"^
-          "
"^Odoc_messages.parameters^": \n"^
-          "\n"^
-             (*border=\"0\" cellpadding=\"5\" cellspacing=\"0\">\n"^*)
-          (String.concat ""
-             (List.map
-                (fun (p, desc_opt) ->
-                  "\n"^
-                  "\n"^
-                  "\n"^
-                  "\n"
-                )
-                l
-             )
-          )^"
\n"^
-                  ""^p.mp_name^":"^(self#html_of_module_type m_name p.mp_type)^"\n"^
-                  (match desc_opt with
-                    None -> ""
-                  | Some t -> "
"^(self#html_of_text t))^
-                  "\n"^
-                  "
\n"^
-          "
\n"
+          bs b "\n";
+          bs b "\n";
+          bs b "\n\n\n
";
+	  bs b Odoc_messages.parameters ;
+	  bs b ": \n";
+          bs b "\n";
+	  List.iter
+            (fun (p, desc_opt) ->
+              bs b "\n";
+              bs b "\n" ;
+              bs b "\n";
+              bs b "\n" ;
+              )
+	    )
+            l;
+          bs b "
\n" ;
+	      bs b p.mp_name;
+              bs b ":" ;
+	      self#html_of_module_parameter_type b m_name p;
+	      bs b "\n";
+              (
+	       match desc_opt with
+                 None -> ()
+               | Some t -> 
+		   bs b "
";
+		   self#html_of_text b t;
+		   bs b "\n
\n
\n"
 
-    (** Return html code for a module. *)
-    method html_of_module ?(info=true) ?(complete=true) ?(with_link=true) m =
+    (** Print html code for a module. *)
+    method html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m =
       let (html_file, _) = Naming.html_files m.m_name in
       let father = Name.father m.m_name in
-      let buf = Buffer.create 32 in
-      let p = Printf.bprintf in
-      p buf "
%s " (self#keyword "module");
+      bs b "
";
+      bs b ((self#keyword "module")^" ");
       (
        if with_link then
-         p buf "%s" html_file (Name.simple m.m_name)
+         bp b "%s" html_file (Name.simple m.m_name)
        else
-         p buf "%s" (Name.simple m.m_name)
+         bs b (Name.simple m.m_name)
       );
-      p buf ": %s
" (self#html_of_module_type father m.m_type);
+      bs b ": ";
+      self#html_of_module_kind b father ~modu: m m.m_kind;
+      bs b "
";
       if info then
-        p buf "%s" ((if complete then self#html_of_info else self#html_of_info_first_sentence) m.m_info)
+        (
+	 if complete then 
+	   self#html_of_info ~indent: false
+	 else 
+	   self#html_of_info_first_sentence 
+	) b m.m_info
       else
-        ();
-      Buffer.contents buf
+        ()
 
-    (** Return html code for a module type. *)
-    method html_of_modtype ?(info=true) ?(complete=true) ?(with_link=true) mt =
+    (** Print html code for a module type. *)
+    method html_of_modtype b ?(info=true) ?(complete=true) ?(with_link=true) mt =
       let (html_file, _) = Naming.html_files mt.mt_name in
       let father = Name.father mt.mt_name in
-      let buf = Buffer.create 32 in
-      let p = Printf.bprintf in
-      p buf "
%s " (self#keyword "module type");
+      bs b "
";
+      bs b ((self#keyword "module type")^" ");
       (
        if with_link then
-         p buf "%s" html_file (Name.simple mt.mt_name)
+         bp b "%s" html_file (Name.simple mt.mt_name)
          else
-         p buf "%s" (Name.simple mt.mt_name)
+         bs b (Name.simple mt.mt_name)
       );
-      (match mt.mt_type with
+      (match mt.mt_kind with
         None -> ()
-      | Some mtyp -> p buf " = %s" (self#html_of_module_type father mtyp)
+      | Some k -> 
+	  bs b " = ";
+	  self#html_of_module_type_kind b father ~mt k
       );
-      Buffer.add_string buf "
";
+      bs b "
";
       if info then
-        p buf "%s" ((if complete then self#html_of_info else self#html_of_info_first_sentence) mt.mt_info)
+        (
+	 if complete then 
+	   self#html_of_info ~indent: false
+	 else
+	   self#html_of_info_first_sentence
+	) b mt.mt_info
       else
-        ();
-      Buffer.contents buf
+        ()
 
-    (** Return html code for an included module. *)
-    method html_of_included_module im =
-      "
"^(self#keyword "include")^" "^
+    (** Print html code for an included module. *)
+    method html_of_included_module b im =
+      bs b "
";
+      bs b ((self#keyword "include")^" ");
       (
        match im.im_module with
          None ->
-           im.im_name
+           bs b im.im_name
        | Some mmt ->
            let (file, name) = 
              match mmt with
@@ -1226,21 +1649,114 @@ class html =
                  let (html_file, _) = Naming.html_files mt.mt_name in
                  (html_file, mt.mt_name)
            in
-           ""^(Name.simple name)^""
-      )^
-      "
\n"
+           bp b "%s" file name
+      );
+      bs b "
\n";
+      self#html_of_info b im.im_info
+
+    method html_of_class_element b element =
+      match element with
+        Class_attribute a ->
+          self#html_of_attribute b a
+      | Class_method m ->
+          self#html_of_method b m
+      | Class_comment t ->
+          self#html_of_class_comment b t
+
+    method html_of_class_kind b father ?cl kind =
+      match kind with
+        Class_structure (inh, eles) -> 
+	  self#html_of_text b [Code "object"];
+	  (
+	   match cl with
+	     None ->
+	       bs b "\n";
+	       (
+		match inh with
+		  [] -> ()
+		| _ -> 
+		    self#generate_inheritance_info b inh
+	       );
+	       List.iter (self#html_of_class_element b) eles;
+	   | Some cl ->
+	       let (html_file, _) = Naming.html_files cl.cl_name in
+	       bp b " .. " html_file
+	  );
+	  self#html_of_text b [Code "end"]
+
+      | Class_apply capp ->
+	  (* TODO: afficher le type final à partir du typedtree *)
+	  self#html_of_text b [Raw "class application not handled yet"]
+            
+      | Class_constr cco ->
+	  (
+           match cco.cco_type_parameters with
+             [] -> ()
+           | l -> 
+               self#html_of_class_type_param_expr_list b father l;
+	       bs b " "
+	  );
+	  self#html_of_text b
+	    [Code (self#create_fully_qualified_idents_links father cco.cco_name)]
+
+      | Class_constraint (ck, ctk) ->
+          self#html_of_text b [Code "( "] ;
+          self#html_of_class_kind b father ck;
+          self#html_of_text b [Code " : "] ;
+          self#html_of_class_type_kind b father ctk;
+          self#html_of_text b [Code " )"]
+
+    method html_of_class_type_kind b father ?ct kind =
+      match kind with
+        Class_type cta -> 
+          (
+           match cta.cta_type_parameters with
+             [] -> ()
+           | l -> 
+	       self#html_of_class_type_param_expr_list b father l;
+	       bs b " "
+          );
+          self#html_of_text b
+	    [Code (self#create_fully_qualified_idents_links father cta.cta_name)]
+
+      | Class_signature (inh, eles) -> 
+	  self#html_of_text b [Code "object"];
+	  (
+	   match ct with
+	     None ->
+	       bs b "\n";
+	       (
+		match inh with
+		  [] -> ()
+		| _ -> self#generate_inheritance_info b inh
+	       );
+	       List.iter (self#html_of_class_element b) eles
+	   | Some ct ->
+	       let (html_file, _) = Naming.html_files ct.clt_name in
+	       bp b " .. " html_file
+	  );
+	  self#html_of_text b [Code "end"]
+
+    method html_of_class_parameter b father p =
+      self#html_of_type_expr b father (Parameter.typ p)
+
+    method html_of_class_parameter_list b father params =
+      List.iter
+	(fun p -> 
+	  self#html_of_class_parameter b father p;
+	  bs b " -> ")
+	params
 
-    (** Return html code for a class. *)
-    method html_of_class ?(complete=true) ?(with_link=true) c =
+    (** Print html code for a class. *)
+    method html_of_class b ?(complete=true) ?(with_link=true) c =
       let father = Name.father c.cl_name in
       Odoc_info.reset_type_names ();
-      let buf = Buffer.create 32 in
       let (html_file, _) = Naming.html_files c.cl_name in
-      let p = Printf.bprintf in
-      p buf "
%s " (self#keyword "class");
+      bs b "
";
+      bs b ((self#keyword "class")^" ");
       (* we add a html tag, the same as for a type so we can 
          go directly here when the class name is used as a type name *)
-      p buf ""
+      bp b ""
         (Naming.type_target 
            { ty_name = c.cl_name ;
              ty_info = None ; ty_parameters = [] ;
@@ -1250,41 +1766,44 @@ class html =
 	   }
 	);
       print_DEBUG "html#html_of_class : virtual or not" ;
-      if c.cl_virtual then p buf "%s " (self#keyword "virtual") else ();
+      if c.cl_virtual then bs b ((self#keyword "virtual")^" ");
       (
        match c.cl_type_parameters with
          [] -> ()
        | l -> 
-           p buf "[%s] "
-             (self#html_of_type_expr_list father ", " l)
+           self#html_of_class_type_param_expr_list b father l;
+	   bs b " "
       );
       print_DEBUG "html#html_of_class : with link or not" ;
       (
        if with_link then
-         p buf "%s" html_file (Name.simple c.cl_name)
+         bp b "%s" html_file (Name.simple c.cl_name)
        else
-         p buf "%s" (Name.simple c.cl_name)
+         bs b (Name.simple c.cl_name)
       );
 
-      Buffer.add_string buf " : " ;
-      Buffer.add_string buf (self#html_of_class_type_expr father c.cl_type);
-      Buffer.add_string buf "
" ;
+      bs b " : " ;
+      self#html_of_class_parameter_list b father c.cl_parameters ;
+      self#html_of_class_kind b father ~cl: c c.cl_kind;
+      bs b "
" ;
       print_DEBUG "html#html_of_class : info" ;
-      Buffer.add_string buf 
-        ((if complete then self#html_of_info else self#html_of_info_first_sentence) c.cl_info);
-      Buffer.contents buf
-
-    (** Return html code for a class type. *)
-    method html_of_class_type ?(complete=true) ?(with_link=true) ct =
+      (
+       if complete then 
+	 self#html_of_info ~indent: false
+       else 
+	 self#html_of_info_first_sentence
+      ) b c.cl_info
+
+    (** Print html code for a class type. *)
+    method html_of_class_type b ?(complete=true) ?(with_link=true) ct =
       Odoc_info.reset_type_names ();
       let father = Name.father ct.clt_name in
-      let buf = Buffer.create 32 in
-      let p = Printf.bprintf in
       let (html_file, _) = Naming.html_files ct.clt_name in
-      p buf "
%s " (self#keyword "class type");
+      bs b "
";
+      bs b ((self#keyword "class type")^" ");
       (* we add a html tag, the same as for a type so we can 
          go directly here when the class type name is used as a type name *)
-      p buf ""
+      bp b ""
         (Naming.type_target 
            { ty_name = ct.clt_name ;
              ty_info = None ; ty_parameters = [] ;
@@ -1293,24 +1812,29 @@ class html =
 	     ty_code = None ;
 	   }
 	);
-      if ct.clt_virtual then p buf "%s "(self#keyword "virtual") else ();
+      if ct.clt_virtual then bs b ((self#keyword "virtual")^" ");
       (
        match ct.clt_type_parameters with
         [] -> ()
-      | l -> p buf "[%s] " (self#html_of_type_expr_list father ", " l)
+      | l -> 
+	  self#html_of_class_type_param_expr_list b father l;
+	  bs b " " 
       );
 
       if with_link then
-        p buf "%s" html_file (Name.simple ct.clt_name)
+        bp b "%s" html_file (Name.simple ct.clt_name)
       else
-        p buf "%s" (Name.simple ct.clt_name);
-
-      Buffer.add_string buf " = ";
-      Buffer.add_string buf (self#html_of_class_type_expr father ct.clt_type);
-      Buffer.add_string buf "
";
-      Buffer.add_string buf ((if complete then self#html_of_info else self#html_of_info_first_sentence) ct.clt_info);
+        bs b (Name.simple ct.clt_name);
 
-      Buffer.contents buf
+      bs b " = ";
+      self#html_of_class_type_kind b father ~ct ct.clt_kind;
+      bs b "
";
+      (
+       if complete then 
+	 self#html_of_info ~indent: false
+       else 
+	 self#html_of_info_first_sentence
+      ) b ct.clt_info
 
     (** Return html code to represent a dag, represented as in Odoc_dag2html. *)
     method html_of_dag dag =
@@ -1334,12 +1858,14 @@ class html =
       let a = Array.map f dag.Odoc_dag2html.dag in
       Odoc_dag2html.html_of_dag { Odoc_dag2html.dag = a }
 
-    (** Return html code for a module comment.*)
-    method html_of_module_comment text =
-      "
\n"^(self#html_of_text text)^"

\n"
+    (** Print html code for a module comment.*)
+    method html_of_module_comment b text =
+      bs b "
\n";
+      self#html_of_text b text;
+      bs b "
\n"
 
-    (** Return html code for a class comment.*)
-    method html_of_class_comment text =
+    (** Print html code for a class comment.*)
+    method html_of_class_comment b text =
       (* Add some style if there is no style for the first part of the text. *)
       let text2 =
         match text with
@@ -1347,10 +1873,10 @@ class html =
             (Odoc_info.Title (2, None, [Odoc_info.Raw s])) :: q
         | _ -> text
       in
-      self#html_of_text text2
+      self#html_of_text b text2
 
     (** Generate html code for the given list of inherited classes.*)
-    method generate_inheritance_info chanout inher_l =
+    method generate_inheritance_info b inher_l =
       let f inh =
         match inh.ic_class with
           None -> (* we can't make the link. *)
@@ -1376,17 +1902,16 @@ class html =
         Odoc_info.List (List.map f inher_l)
       ] 
       in
-      let html = self#html_of_text text in
-      output_string chanout html
+      self#html_of_text b text 
 
     (** Generate html code for the inherited classes of the given class. *)
-    method generate_class_inheritance_info chanout cl =
+    method generate_class_inheritance_info b cl =
       let rec iter_kind k = 
         match k with
           Class_structure ([], _) ->
             ()
         | Class_structure (l, _) ->
-            self#generate_inheritance_info chanout l
+            self#generate_inheritance_info b l
         | Class_constraint (k, ct) ->
             iter_kind k
         | Class_apply _
@@ -1396,12 +1921,12 @@ class html =
       iter_kind cl.cl_kind
 
     (** Generate html code for the inherited classes of the given class type. *)
-    method generate_class_type_inheritance_info chanout clt =
+    method generate_class_type_inheritance_info b clt =
       match clt.clt_kind with
         Class_signature ([], _) ->
           ()
       | Class_signature (l, _) ->
-          self#generate_inheritance_info chanout l
+          self#generate_inheritance_info b l
       | Class_type _ ->
           ()
 
@@ -1415,31 +1940,27 @@ class html =
     fun elements name info target title simple_file ->
       try
         let chanout = open_out (Filename.concat !Args.target_dir simple_file) in
-        output_string chanout 
-          (
-           "\n"^
-           (self#header (self#inner_title title)) ^
-           "\n"^
-            "
"^title^"
\n");
+	let b = new_buf () in
+	bs b "\n";
+        self#print_header b (self#inner_title title);
+	bs b "\n
";
+	bs b title;
+	bs b "
\n" ;
         
         let sorted_elements = List.sort 
-            (fun e1 -> fun e2 -> compare (Name.simple (name e1)) (Name.simple (name e2)))
+            (fun e1 e2 -> compare (Name.simple (name e1)) (Name.simple (name e2)))
             elements
         in
         let groups = Odoc_info.create_index_lists sorted_elements (fun e -> Name.simple (name e)) in
         let f_ele e =
           let simple_name = Name.simple (name e) in
           let father_name = Name.father (name e) in
-          output_string chanout
-            (""^simple_name^" "^
-             (if simple_name <> father_name && father_name <> "" then 
-               "["^""^father_name^"]"
-             else
-               ""
-             )^
-             "\n"^
-             ""^(self#html_of_info_first_sentence (info e))^"\n"
-            )
+          bp b "%s " (target e) simple_name;
+          if simple_name <> father_name && father_name <> "" then 
+            bp b "[%s]" (fst (Naming.html_files father_name)) father_name;
+          bs b "\n";
+	  self#html_of_info_first_sentence b (info e);
+	  bs b "\n";
         in
         let f_group l =
           match l with
@@ -1450,13 +1971,16 @@ class html =
                   'A'..'Z' as c -> String.make 1 c
                 | _ -> ""
               in
-              output_string chanout ("
"^s^"\n");
+              bs b "
";
+	      bs b s ;
+	      bs b "\n" ;
               List.iter f_ele l
         in
-        output_string chanout "\n";
+        bs b "
\n";
         List.iter f_group groups ;
-        output_string chanout "

\n" ;
-        output_string chanout "\n";
+        bs b "
\n" ;
+        bs b "\n";
+	Buffer.output_buffer chanout b;
         close_out chanout
       with
         Sys_error s ->
@@ -1482,44 +2006,34 @@ class html =
       let type_file = Naming.file_type_class_complete_target cl.cl_name in
       try
         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+	let b = new_buf () in
         let pre_name = opt (fun c -> c.cl_name) pre in
         let post_name = opt (fun c -> c.cl_name) post in
-        output_string chanout
-          ("\n"^
-           (self#header 
-              ~nav: (Some (pre_name, post_name, cl.cl_name))
-              ~comments: (Class.class_comments cl)
-              (self#inner_title cl.cl_name)
-           )^
-           "\n"^
-           (self#navbar pre_name post_name cl.cl_name)^
-           "
"^Odoc_messages.clas^" "^
-           (if cl.cl_virtual then "virtual " else "")^
-           ""^cl.cl_name^""^
-           "
\n"^
-           "
\n"^
-           (self#html_of_class ~with_link: false cl)
-          );
+	bs b "\n";
+        self#print_header b
+          ~nav: (Some (pre_name, post_name, cl.cl_name))
+          ~comments: (Class.class_comments cl)
+          (self#inner_title cl.cl_name);
+	bs b "\n";
+        self#print_navbar b pre_name post_name cl.cl_name;
+        bs b "
";
+	bs b (Odoc_messages.clas^" ");
+        if cl.cl_virtual then bs b "virtual " ;
+        bp b "%s" type_file cl.cl_name;
+        bs b "
\n
\n";
+        self#html_of_class b ~with_link: false cl;
         (* parameters *)
-        output_string chanout 
-          (self#html_of_described_parameter_list (Name.father cl.cl_name) cl.cl_parameters);
+        self#html_of_described_parameter_list b 
+	  (Name.father cl.cl_name) cl.cl_parameters;
         (* class inheritance *)
-        self#generate_class_inheritance_info chanout cl;
+	self#generate_class_inheritance_info b cl;
         (* a horizontal line *)
-        output_string chanout "
\n";
+        bs b "
\n";
         (* the various elements *)
-        List.iter 
-          (fun element ->
-            match element with
-              Class_attribute a ->
-                output_string chanout (self#html_of_attribute a)
-            | Class_method m ->
-                output_string chanout (self#html_of_method m)
-            | Class_comment t ->
-                output_string chanout (self#html_of_class_comment t)
-          )
+        List.iter (self#html_of_class_element b)
           (Class.class_elements ~trans:false cl);
-        output_string chanout "";
+        bs b "";
+	Buffer.output_buffer chanout b;
         close_out chanout;
 
         (* generate the file with the complete class type *)
@@ -1538,41 +2052,33 @@ class html =
       let type_file = Naming.file_type_class_complete_target clt.clt_name in
       try
         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+	let b = new_buf () in
         let pre_name = opt (fun ct -> ct.clt_name) pre in
         let post_name = opt (fun ct -> ct.clt_name) post in
-        output_string chanout
-          ("\n"^
-           (self#header 
-              ~nav: (Some (pre_name, post_name, clt.clt_name))
-              ~comments: (Class.class_type_comments clt)
-              (self#inner_title clt.clt_name)
-           )^
-           "\n"^
-           (self#navbar pre_name post_name clt.clt_name)^
-           "
"^Odoc_messages.class_type^" "^
-           (if clt.clt_virtual then "virtual " else "")^
-           ""^clt.clt_name^""^
-           "
\n"^
-           "
\n"^
-           (self#html_of_class_type ~with_link: false clt)
-          );
+	bs b "\n";
+        self#print_header b
+          ~nav: (Some (pre_name, post_name, clt.clt_name))
+          ~comments: (Class.class_type_comments clt)
+          (self#inner_title clt.clt_name);
+
+        bs b "\n";
+        self#print_navbar b pre_name post_name clt.clt_name;
+        bs b "
";
+	bs b (Odoc_messages.class_type^" ");
+        if clt.clt_virtual then bs b "virtual ";
+        bp b "%s" type_file clt.clt_name;
+        bs b "
\n
\n";
+        self#html_of_class_type b ~with_link: false clt;
+
         (* class inheritance *)
-        self#generate_class_type_inheritance_info chanout clt;
+        self#generate_class_type_inheritance_info b clt;
         (* a horizontal line *)
-        output_string chanout "
\n";
+        bs b "
\n";
         (* the various elements *)
-        List.iter 
-          (fun element ->
-            match element with
-              Class_attribute a ->
-                output_string chanout (self#html_of_attribute a)
-            | Class_method m ->
-                output_string chanout (self#html_of_method m)
-            | Class_comment t ->
-                output_string chanout (self#html_of_class_comment t)
-          )
+        List.iter (self#html_of_class_element b)
           (Class.class_type_elements ~trans: false clt);
-        output_string chanout "";
+        bs b "";
+	Buffer.output_buffer chanout b;
         close_out chanout;
 
         (* generate the file with the complete class type *)
@@ -1591,57 +2097,39 @@ class html =
         let (html_file, _) = Naming.html_files mt.mt_name in
         let type_file = Naming.file_type_module_complete_target mt.mt_name in
         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+	let b = new_buf () in
         let pre_name = opt (fun mt -> mt.mt_name) pre in
         let post_name = opt (fun mt -> mt.mt_name) post in
-        output_string chanout
-          ("\n"^
-           (self#header
-              ~nav: (Some (pre_name, post_name, mt.mt_name))
-              ~comments: (Module.module_type_comments mt)
-              (self#inner_title mt.mt_name)
-           )^
-           "\n"^
-           (self#navbar pre_name post_name mt.mt_name)^
-           "
"^Odoc_messages.module_type^
-           " "^
-           (match mt.mt_type with
-             Some _ -> ""^mt.mt_name^""
-           | None-> mt.mt_name
-           )^
-           "
\n"^
-           "
\n"^
-           (self#html_of_modtype ~with_link: false mt)
-          );
+	bs b "\n";
+        self#print_header b
+          ~nav: (Some (pre_name, post_name, mt.mt_name))
+          ~comments: (Module.module_type_comments mt)
+          (self#inner_title mt.mt_name);
+        bs b "\n";
+        self#print_navbar b pre_name post_name mt.mt_name;
+        bp b "
";
+	bs b (Odoc_messages.module_type^" ");
+        (
+	 match mt.mt_type with
+           Some _ -> bp b "%s" type_file mt.mt_name
+         | None-> bs b mt.mt_name
+        );
+        bs b "
\n
\n" ;
+        self#html_of_modtype b ~with_link: false mt;
+           
         (* parameters for functors *)
-        output_string chanout (self#html_of_module_parameter_list "" (Module.module_type_parameters mt));
+        self#html_of_module_parameter_list b 
+	  (Name.father mt.mt_name)
+	  (Module.module_type_parameters mt);
         (* a horizontal line *)
-        output_string chanout "
\n";
+        bs b "
\n";
         (* module elements *)
-        List.iter 
-          (fun ele ->
-            match ele with
-              Element_module m ->
-                output_string chanout (self#html_of_module ~complete: false m)
-            | Element_module_type mt ->
-                output_string chanout (self#html_of_modtype ~complete: false mt)
-            | Element_included_module im ->
-                output_string chanout (self#html_of_included_module im)
-            | Element_class c ->
-                output_string chanout (self#html_of_class ~complete: false c)
-            | Element_class_type ct ->
-                output_string chanout (self#html_of_class_type ~complete: false ct)
-            | Element_value v ->
-                output_string chanout (self#html_of_value v)
-            | Element_exception e ->
-                output_string chanout (self#html_of_exception e)
-            | Element_type t ->
-                output_string chanout (self#html_of_type t)
-            | Element_module_comment text ->
-                output_string chanout (self#html_of_module_comment text)
-          )
+        List.iter
+	  (self#html_of_module_element b (Name.father mt.mt_name))
           (Module.module_type_elements mt);
 
-        output_string chanout "";       
+        bs b "";
+	Buffer.output_buffer chanout b;
         close_out chanout;
 
         (* generate html files for submodules *)
@@ -1657,7 +2145,8 @@ class html =
         (
          match mt.mt_type with
            None -> ()
-         | Some mty -> self#output_module_type 
+         | Some mty -> 
+	     self#output_module_type 
                mt.mt_name
                (Filename.concat !Args.target_dir type_file) 
                mty
@@ -1673,56 +2162,51 @@ class html =
         Odoc_info.verbose ("Generate for module "^modu.m_name);
         let (html_file, _) = Naming.html_files modu.m_name in
         let type_file = Naming.file_type_module_complete_target modu.m_name in
+        let code_file = Naming.file_code_module_complete_target modu.m_name in
         let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+	let b = new_buf () in
         let pre_name = opt (fun m -> m.m_name) pre in
         let post_name = opt (fun m -> m.m_name) post in
-        output_string chanout
-          ("\n"^
-           (self#header 
-              ~nav: (Some (pre_name, post_name, modu.m_name))
-              ~comments: (Module.module_comments modu)
-              (self#inner_title modu.m_name)
-           ) ^
-           "\n"^
-           (self#navbar pre_name post_name modu.m_name)^
-           "
"^(if Module.module_is_functor modu then Odoc_messages.functo else Odoc_messages.modul)^
-           " "^
-           ""^modu.m_name^""^
-           "
\n"^
-           "
\n"^
-           (self#html_of_module ~with_link: false modu)
-          );
+	bs b "\n";
+        self#print_header b
+          ~nav: (Some (pre_name, post_name, modu.m_name))
+          ~comments: (Module.module_comments modu)
+          (self#inner_title modu.m_name);
+	bs b "\n" ;
+        self#print_navbar b pre_name post_name modu.m_name ;
+        bs b "
";
+	bs b 
+	  (
+	   if Module.module_is_functor modu then 
+	     Odoc_messages.functo 
+	   else 
+	     Odoc_messages.modul
+	  );
+	bp b " %s" type_file modu.m_name;
+	(
+	 match modu.m_code with
+	   None -> ()
+	 | Some _ -> bp b " (.ml)" code_file
+	);
+        bs b "
\n
\n";
+
+        self#html_of_module b ~with_link: false modu;
+
         (* parameters for functors *)
-        output_string chanout (self#html_of_module_parameter_list "" (Module.module_parameters modu));
+        self#html_of_module_parameter_list b
+	  (Name.father modu.m_name)
+	  (Module.module_parameters modu);
+
         (* a horizontal line *)
-        output_string chanout "
\n";
+        bs b "
\n";
+
         (* module elements *)
         List.iter 
-          (fun ele ->
-            print_DEBUG "html#generate_for_module : ele ->";
-            match ele with
-              Element_module m ->
-                output_string chanout (self#html_of_module ~complete: false m)
-            | Element_module_type mt ->
-                output_string chanout (self#html_of_modtype ~complete: false mt)
-            | Element_included_module im ->
-                output_string chanout (self#html_of_included_module im)
-            | Element_class c ->
-                output_string chanout (self#html_of_class ~complete: false c)
-            | Element_class_type ct ->
-                output_string chanout (self#html_of_class_type ~complete: false ct)
-            | Element_value v ->
-                output_string chanout (self#html_of_value v)
-            | Element_exception e ->
-                output_string chanout (self#html_of_exception e)
-            | Element_type t ->
-                output_string chanout (self#html_of_type t)
-            | Element_module_comment text ->
-                output_string chanout (self#html_of_module_comment text)
-          )
+          (self#html_of_module_element b (Name.father modu.m_name))
           (Module.module_elements modu);
 
-        output_string chanout "";
+        bs b "";
+	Buffer.output_buffer chanout b;
         close_out chanout;
 
         (* generate html files for submodules *)
@@ -1738,7 +2222,15 @@ class html =
         self#output_module_type 
           modu.m_name
           (Filename.concat !Args.target_dir type_file)
-          modu.m_type
+          modu.m_type;
+
+	match modu.m_code with
+	  None -> ()
+	| Some code ->
+	    self#output_code
+	      modu.m_name
+	      (Filename.concat !Args.target_dir code_file)
+	      code
       with
         Sys_error s ->
           raise (Failure s)
@@ -1747,43 +2239,28 @@ class html =
        @raise Failure if an error occurs.*)
     method generate_index module_list =
       try
+        let chanout = open_out (Filename.concat !Args.target_dir self#index) in
+	let b = new_buf () in
         let title = match !Args.title with None -> "" | Some t -> self#escape t in
-        let index_if_not_empty l url m =
-          match l with
-            [] -> ""
-          | _ -> ""^m^"
\n"
-        in
-        let chanout = open_out (Filename.concat !Args.target_dir index) in
-        output_string chanout 
-          (
-           "\n"^
-           (self#header self#title) ^
-           "\n"^
-           "
"^title^"
\n"^
-           (index_if_not_empty list_types index_types Odoc_messages.index_of_types)^
-           (index_if_not_empty list_exceptions index_exceptions Odoc_messages.index_of_exceptions)^
-           (index_if_not_empty list_values index_values Odoc_messages.index_of_values)^
-           (index_if_not_empty list_attributes index_attributes Odoc_messages.index_of_attributes)^
-           (index_if_not_empty list_methods index_methods Odoc_messages.index_of_methods)^
-           (index_if_not_empty list_classes index_classes Odoc_messages.index_of_classes)^
-           (index_if_not_empty list_class_types index_class_types Odoc_messages.index_of_class_types)^
-           (index_if_not_empty list_modules index_modules Odoc_messages.index_of_modules)^
-           (index_if_not_empty list_module_types index_module_types Odoc_messages.index_of_module_types)^
-           "
\n"^
-           "\n"^
-           (String.concat ""
-              (List.map
-                 (fun m ->
-                   let (html, _) = Naming.html_files m.m_name in
-                   ""^
-                   "\n")
-                 module_list
-              )
-           )^
-           "
"^m.m_name^""^(self#html_of_info_first_sentence m.m_info)^"
\n"^
-           "\n"^
-           ""
-          );
+	bs b "\n";
+        self#print_header b self#title;
+        bs b "\n";
+        bs b "
";
+	bs b title; 
+	bs b "
\n" ;
+	let info = Odoc_info.apply_opt
+	    Odoc_info.info_of_comment_file !Odoc_info.Args.intro_file 
+	in
+	(
+	 match info with
+	   None ->
+	     self#html_of_Index_list b;
+	     bs b "
";
+	     self#html_of_Module_list b
+	       (List.map (fun m -> m.m_name) module_list)
+	 | Some i -> self#html_of_info ~indent: false b info
+	);
+	Buffer.output_buffer chanout b;
         close_out chanout
       with
         Sys_error s ->
@@ -1792,93 +2269,93 @@ class html =
     (** Generate the values index in the file [index_values.html]. *)
     method generate_values_index module_list =
       self#generate_elements_index 
-        list_values
+        self#list_values
         (fun v -> v.val_name) 
         (fun v -> v.val_info)
         Naming.complete_value_target
         Odoc_messages.index_of_values
-        index_values
+        self#index_values
 
     (** Generate the exceptions index in the file [index_exceptions.html]. *)
     method generate_exceptions_index module_list =
       self#generate_elements_index 
-        list_exceptions
+        self#list_exceptions
         (fun e -> e.ex_name) 
         (fun e -> e.ex_info)
         Naming.complete_exception_target
         Odoc_messages.index_of_exceptions
-        index_exceptions
+        self#index_exceptions
 
     (** Generate the types index in the file [index_types.html]. *)
     method generate_types_index module_list =
       self#generate_elements_index 
-        list_types
+        self#list_types
         (fun t -> t.ty_name) 
         (fun t -> t.ty_info)
         Naming.complete_type_target
         Odoc_messages.index_of_types
-        index_types
+        self#index_types
 
     (** Generate the attributes index in the file [index_attributes.html]. *)
     method generate_attributes_index module_list =
       self#generate_elements_index 
-        list_attributes
+        self#list_attributes
         (fun a -> a.att_value.val_name) 
         (fun a -> a.att_value.val_info)
         Naming.complete_attribute_target
         Odoc_messages.index_of_attributes
-        index_attributes
+        self#index_attributes
 
     (** Generate the methods index in the file [index_methods.html]. *)
     method generate_methods_index module_list =
       self#generate_elements_index 
-        list_methods
+        self#list_methods
         (fun m -> m.met_value.val_name) 
         (fun m -> m.met_value.val_info)
         Naming.complete_method_target
         Odoc_messages.index_of_methods
-        index_methods
+        self#index_methods
 
     (** Generate the classes index in the file [index_classes.html]. *)
     method generate_classes_index module_list =
       self#generate_elements_index
-        list_classes
+        self#list_classes
         (fun c -> c.cl_name) 
         (fun c -> c.cl_info)
         (fun c -> fst (Naming.html_files c.cl_name))
         Odoc_messages.index_of_classes
-        index_classes
+        self#index_classes
 
     (** Generate the class types index in the file [index_class_types.html]. *)
     method generate_class_types_index module_list =
       self#generate_elements_index
-        list_class_types
+        self#list_class_types
         (fun ct -> ct.clt_name) 
         (fun ct -> ct.clt_info)
         (fun ct -> fst (Naming.html_files ct.clt_name))
         Odoc_messages.index_of_class_types
-        index_class_types
+        self#index_class_types
 
     (** Generate the modules index in the file [index_modules.html]. *)
     method generate_modules_index module_list =
       self#generate_elements_index
-        list_modules
+        self#list_modules
         (fun m -> m.m_name) 
         (fun m -> m.m_info)
         (fun m -> fst (Naming.html_files m.m_name))
         Odoc_messages.index_of_modules
-        index_modules
+        self#index_modules
 
     (** Generate the module types index in the file [index_module_types.html]. *)
     method generate_module_types_index module_list =
       let module_types = Odoc_info.Search.module_types module_list in
       self#generate_elements_index
-        list_module_types
+        self#list_module_types
         (fun mt -> mt.mt_name) 
         (fun mt -> mt.mt_info)
         (fun mt -> fst (Naming.html_files mt.mt_name))
         Odoc_messages.index_of_module_types
-        index_module_types
+        self#index_module_types
 
     (** Generate all the html files from a module list. The main
        file is [index.html]. *)
@@ -1900,20 +2377,37 @@ class html =
       self#prepare_header module_list ;
       (* Get the names of all known types. *)
       let types = Odoc_info.Search.types module_list in
-      let type_names = List.map (fun t -> t.ty_name) types in
-      known_types_names <- type_names ;
+      known_types_names <- 
+	List.fold_left 
+	  (fun acc t -> StringSet.add t.ty_name acc) 
+	  known_types_names
+	  types ;
       (* Get the names of all class and class types. *)
       let classes = Odoc_info.Search.classes module_list in
       let class_types = Odoc_info.Search.class_types module_list in
-      let class_names = List.map (fun c -> c.cl_name) classes in
-      let class_type_names = List.map (fun ct -> ct.clt_name) class_types in
-      known_classes_names <- class_names @ class_type_names ;
+      known_classes_names <- 
+	List.fold_left
+	  (fun acc c -> StringSet.add c.cl_name acc) 
+	  known_classes_names 
+	  classes ;
+      known_classes_names <-  
+	List.fold_left
+	  (fun acc ct -> StringSet.add ct.clt_name acc) 
+	  known_classes_names
+	  class_types ;
       (* Get the names of all known modules and module types. *)
       let module_types = Odoc_info.Search.module_types module_list in
       let modules = Odoc_info.Search.modules module_list in
-      let module_type_names = List.map (fun mt -> mt.mt_name) module_types in
-      let module_names = List.map (fun m -> m.m_name) modules in
-      known_modules_names <- module_type_names @ module_names ;
+      known_modules_names <-
+	List.fold_left 
+	  (fun acc m -> StringSet.add m.m_name acc) 
+	  known_modules_names 
+	  modules ;
+      known_modules_names <-
+	List.fold_left
+	  (fun acc mt -> StringSet.add mt.mt_name acc) 
+	  known_modules_names 
+	  module_types ;
       (* generate html for each module *)
       if not !Args.index_only then 
         self#generate_elements self#generate_for_module module_list ;
@@ -1936,8 +2430,13 @@ class html =
 
     initializer
       Odoc_ocamlhtml.html_of_comment := 
-        (fun s -> self#html_of_text (Odoc_text.Texter.text_of_string s))
+        (fun s -> 
+	  let b = new_buf () in
+	  self#html_of_text b (Odoc_text.Texter.text_of_string s);
+	  Buffer.contents b
+	)
   end
 
 
                              
+(* eof $Id: odoc_html.ml,v 1.52.4.1 2004/06/25 13:39:16 guesdon Exp $ *)
diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml
index 7438fd61..c0df8a76 100644
--- a/ocamldoc/odoc_info.ml
+++ b/ocamldoc/odoc_info.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_info.ml,v 1.20 2004/05/23 10:41:50 guesdon Exp $ *)
 
 (** Interface for analysing documented OCaml source files and to the collected information. *)
 
@@ -45,10 +46,13 @@ and text_element = Odoc_types.text_element =
   | Ref of string * ref_kind option
   | Superscript of text
   | Subscript of text
-
+  | Module_list of string list
+  | Index_list
 
 and text = text_element list
 
+exception Text_syntax = Odoc_text.Text_syntax
+
 type see_ref = Odoc_types.see_ref =
     See_url of string
   | See_file of string
@@ -112,15 +116,17 @@ let reset_type_names = Printtyp.reset
 
 let string_of_variance t (co,cn) = Odoc_str.string_of_variance t (co, cn)
 
-let string_of_type_expr t = Odoc_misc.string_of_type_expr t
+let string_of_type_expr t = Odoc_print.string_of_type_expr t
 
-let string_of_type_list sep type_list = Odoc_str.string_of_type_list sep type_list
+let string_of_type_list ?par sep type_list = Odoc_str.string_of_type_list ?par sep type_list
 
 let string_of_type_param_list t = Odoc_str.string_of_type_param_list t
 
-let string_of_module_type = Odoc_misc.string_of_module_type
+let string_of_class_type_param_list l = Odoc_str.string_of_class_type_param_list l
 
-let string_of_class_type = Odoc_misc.string_of_class_type
+let string_of_module_type = Odoc_print.string_of_module_type
+
+let string_of_class_type = Odoc_print.string_of_class_type
 
 let string_of_text t = Odoc_misc.string_of_text t
 
@@ -173,6 +179,129 @@ let apply_if_equal f v1 v2 =
   else
     v2
 
+let text_of_string = Odoc_text.Texter.text_of_string
+
+let text_string_of_text = Odoc_text.Texter.string_of_text
+
+
+let escape_arobas s =
+  let len = String.length s in
+  let b = Buffer.create len in
+  for i = 0 to len - 1 do
+    match s.[i] with
+      '@' -> Buffer.add_string b "\\@"
+    | c -> Buffer.add_char b c
+  done;
+  Buffer.contents b
+
+let info_string_of_info i =
+  let b = Buffer.create 256 in
+  let p = Printf.bprintf in
+  (
+   match i.i_desc with 
+     None -> ()
+   | Some t -> p b "%s" (escape_arobas (text_string_of_text t))
+  );
+  List.iter 
+    (fun s -> p b "\n@author %s" (escape_arobas s))
+    i.i_authors;
+  (
+   match i.i_version with
+     None -> ()
+   | Some s -> p b "\n@version %s" (escape_arobas s)
+  );
+  (
+   (* TODO: escape characters ? *)
+   let f_see_ref = function
+       See_url s -> Printf.sprintf "<%s>" s
+     | See_file s -> Printf.sprintf "'%s'" s
+     | See_doc s -> Printf.sprintf "\"%s\"" s
+   in
+   List.iter
+     (fun (sref, t) ->
+       p b "\n@see %s %s"
+	 (escape_arobas (f_see_ref sref))
+	 (escape_arobas (text_string_of_text t))
+     )
+     i.i_sees
+  );
+  (
+   match i.i_since with
+     None -> ()
+   | Some s -> p b "\n@since %s" (escape_arobas s)
+  );
+  (
+   match i.i_deprecated with 
+     None -> ()
+   | Some t -> 
+       p b "\n@deprecated %s" 
+	 (escape_arobas (text_string_of_text t))
+  );
+  List.iter
+    (fun (s, t) ->
+      p b "\n@param %s %s"
+	(escape_arobas s)
+	(escape_arobas (text_string_of_text t))
+    )
+    i.i_params;
+  List.iter
+    (fun (s, t) ->
+      p b "\n@raise %s %s"
+	(escape_arobas s)
+	(escape_arobas (text_string_of_text t))
+    )
+    i.i_raised_exceptions;
+  (
+   match i.i_return_value with 
+     None -> ()
+   | Some t -> 
+       p b "\n@return %s" 
+	 (escape_arobas (text_string_of_text t))
+  );
+  List.iter
+    (fun (s, t) ->
+      p b "\n@%s %s" s
+	(escape_arobas (text_string_of_text t))
+    )
+    i.i_raised_exceptions;
+  List.iter
+    (fun (s, t) ->
+      p b "\n@%s %s" s
+	(escape_arobas (text_string_of_text t))
+    )
+    i.i_custom;
+
+  Buffer.contents b
+
+let info_of_string s =
+  let dummy =
+    {
+      i_desc = None ;
+      i_authors = [] ;
+      i_version = None ;
+      i_sees = [] ;
+      i_since = None ;
+      i_deprecated = None ;
+      i_params = [] ;
+      i_raised_exceptions = [] ;
+      i_return_value = None ;
+      i_custom = [] ;
+    } 
+  in
+  let s2 = Printf.sprintf "(** %s *)" s in
+  let (_, i_opt) = Odoc_comments.Basic_info_retriever.first_special "-" s2 in
+  match i_opt with
+    None -> dummy
+  | Some i -> i
+      
+let info_of_comment_file f =
+  try
+    let s = Odoc_misc.input_file_as_string f in
+    info_of_string s
+  with
+    Sys_error s -> 
+      failwith s
+
 module Search = 
   struct 
     type result_element = Odoc_search.result_element =
diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
index a9dfa90d..e6a3f645 100644
--- a/ocamldoc/odoc_info.mli
+++ b/ocamldoc/odoc_info.mli
@@ -9,6 +9,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_info.mli,v 1.36 2004/05/23 10:41:50 guesdon Exp $ *)
+
 (** Interface to the information collected in source files. *)
 
 (** The differents kinds of element references. *)
@@ -47,6 +49,9 @@ and text_element = Odoc_types.text_element =
        (** A reference to an element. Complete name and kind. *)
   | Superscript of text (** Superscripts. *)
   | Subscript of text (** Subscripts. *)
+  | Module_list of string list
+       (** The table of the given modules with their abstract. *)
+  | Index_list (** The links to the various indexes (values, types, ...) *)
 
 (** A text is a list of [text_element]. The order matters. *)
 and text = text_element list
@@ -57,6 +62,10 @@ type see_ref = Odoc_types.see_ref =
   | See_file of string
   | See_doc of string
 
+(** Raised when parsing string to build a {!Odoc_info.text}
+   structure. [(line, char, string)] *)
+exception Text_syntax of int * int * string 
+
 (** The information in a \@see tag. *)
 type see = see_ref * text
 
@@ -132,13 +141,6 @@ module Parameter :
     (** A parameter is just a param_info.*)
     type parameter = param_info
 
-    (** A module parameter is just a name and a module type.*)
-    type module_parameter = Odoc_parameter.module_parameter =
-        {
-          mp_name : string ;
-          mp_type : Types.module_type ;
-        } 
-    
     (** {3 Functions} *)
     (** Acces to the name as a string. For tuples, parenthesis and commas are added. *)
     val complete_name : parameter -> string
@@ -407,6 +409,7 @@ module Module :
         {
           im_name : Name.t ; (** Complete name of the included module. *)
           mutable im_module : mmt option ; (** The included module or module type, if we found it. *)
+	  mutable im_info : Odoc_types.info option ; (** comment associated to the includ directive *)
         } 
           
     and module_alias = Odoc_module.module_alias = 
@@ -415,12 +418,19 @@ module Module :
           mutable ma_module : mmt option ; (** The real module or module type if we could associate it. *)
         } 
 
+    and module_parameter = Odoc_module.module_parameter = {
+	mp_name : string ; (** the name *)
+	mp_type : Types.module_type ; (** the type *)
+	mp_type_code : string ; (** the original code *)
+	mp_kind : module_type_kind ; (** the way the parameter was built *)
+      } 
+
     (** Different kinds of a module. *)
     and module_kind = Odoc_module.module_kind = 
       | Module_struct of module_element list (** A complete module structure. *)
       | Module_alias of module_alias (** Complete name and corresponding module if we found it *)
-      | Module_functor of (Parameter.module_parameter list) * module_kind 
-                     (** A functor, with {e all} its parameters and the rest of its definition *)
+      | Module_functor of module_parameter * module_kind 
+                     (** A functor, with its parameter and the rest of its definition *)
       | Module_apply of module_kind * module_kind
                      (** A module defined by application of a functor. *)
       | Module_with of module_type_kind * string
@@ -440,6 +450,8 @@ module Module :
           mutable m_kind : module_kind ; (** The way the module is defined. *)
           mutable m_loc : location ;
           mutable m_top_deps : Name.t list ; (** The toplevels module names this module depends on. *)
+	  mutable m_code : string option ; (** The whole code of the module *)
+	  mutable m_code_intf : string option ; (** The whole code of the interface of the module *)
         } 
 
     and module_type_alias = Odoc_module.module_type_alias =
@@ -451,8 +463,8 @@ module Module :
     (** Different kinds of module type. *)
     and module_type_kind = Odoc_module.module_type_kind = 
       | Module_type_struct of module_element list (** A complete module signature. *)
-      | Module_type_functor of (Odoc_parameter.module_parameter list) * module_type_kind
-            (** A functor, with {e all} its parameters and the rest of its definition *)
+      | Module_type_functor of module_parameter * module_type_kind
+            (** A functor, with its parameter and the rest of its definition *)
       | Module_type_alias of module_type_alias
             (** Complete alias name and corresponding module type if we found it. *)
       | Module_type_with of module_type_kind * string
@@ -515,7 +527,7 @@ module Module :
     val module_is_functor : t_module -> bool
 
     (** The list of couples (module parameter, optional description). *)
-    val module_parameters : ?trans:bool-> t_module -> (Parameter.module_parameter * text option) list
+    val module_parameters : ?trans:bool-> t_module -> (module_parameter * text option) list
 
     (** The list of module comments. *)
     val module_comments : ?trans:bool-> t_module -> text list
@@ -562,7 +574,7 @@ module Module :
     val module_type_is_functor : t_module_type -> bool
 
     (** The list of couples (module parameter, optional description). *)
-    val module_type_parameters : ?trans:bool-> t_module_type -> (Parameter.module_parameter * text option) list
+    val module_type_parameters : ?trans:bool-> t_module_type -> (module_parameter * text option) list
 
     (** The list of module comments. *)
     val module_type_comments : ?trans:bool-> t_module_type -> text list
@@ -609,17 +621,24 @@ val string_of_type_expr : Types.type_expr -> string
 
 (** This function returns a string to represent the given list of types,
    with a given separator. *)
-val string_of_type_list : string -> Types.type_expr list -> string
+val string_of_type_list : ?par: bool -> string -> Types.type_expr list -> string
 
 (** This function returns a string to represent the list of type parameters
    for the given type. *)
 val string_of_type_param_list : Type.t_type -> string
 
+(** This function returns a string to represent the given list of 
+   type parameters of a class or class type,
+   with a given separator. *)
+val string_of_class_type_param_list : Types.type_expr list -> string
+
 (** This function returns a string representing a [Types.module_type]. 
    @param complete indicates if we must print complete signatures
    or just [sig end]. Default if [false].
+   @param code if [complete = false] and the type contains something else
+   than identificators and functors, then the given code is used.
 *)
-val string_of_module_type : ?complete: bool -> Types.module_type -> string
+val string_of_module_type : ?code: string -> ?complete: bool -> Types.module_type -> string
 
 (** This function returns a string representing a [Types.class_type]. 
    @param complete indicates if we must print complete signatures
@@ -716,6 +735,37 @@ val apply_opt : ('a -> 'b) -> 'a option -> 'b option
    are different, return the second one.*)
 val apply_if_equal : ('a -> 'a) -> 'a -> 'a -> 'a
 
+(** [text_of_string s] returns the text structure from the
+   given string. 
+   @raise Text_syntax if a syntax error is encountered. *)
+val text_of_string : string -> text
+
+(** [text_string_of_text text] returns the string representing
+   the given [text]. This string can then be parsed again
+   by {!Odoc_info.text_of_string}.*)   
+val text_string_of_text : text -> string
+
+(** [info_of_string s] parses the given string
+   like a regular ocamldoc comment and return an 
+   {!Odoc_info.info} structure.
+   @return an empty structure if there was a syntax error. TODO: change this
+*)
+val info_of_string : string -> info
+
+(** [info_string_of_info info] returns the string representing
+   the given [info]. This string can then be parsed again
+   by {!Odoc_info.info_of_string}.*)   
+val info_string_of_info : info -> string
+
+(** [info_of_comment_file file] parses the given file
+   and return an {!Odoc_info.info} structure. The content of the 
+   file must have the same syntax as the content of a special comment.
+   @raise Failure is the file could not be opened or there is a
+   syntax error.
+*)
+val info_of_comment_file : string -> info
+
+
 (** Research in elements *)
 module Search :
     sig
@@ -887,7 +937,13 @@ module Args :
     
       (** The optional title to use in the generated documentation. *)
       val title : string option ref
+
+      (** To keep the code while merging, when we have both .ml and .mli files for a module. *)
+      val keep_code : bool ref
     
+      (** The optional file whose content can be used as intro text. *)
+      val intro_file : string option ref
+
       (** Flag to indicate whether we must display the complete list of parameters
 	 for functions and methods. *)
       val with_parameter_list : bool ref
diff --git a/ocamldoc/odoc_inherit.ml b/ocamldoc/odoc_inherit.ml
index 7519a782..915b4cb0 100644
--- a/ocamldoc/odoc_inherit.ml
+++ b/ocamldoc/odoc_inherit.ml
@@ -9,5 +9,5 @@
 (*                                                                     *)
 (***********************************************************************)
 
-
+(* $Id: odoc_inherit.ml,v 1.2 2003/11/24 10:41:04 starynke Exp $ *)
 
diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
index f033696c..0d1ca193 100644
--- a/ocamldoc/odoc_latex.ml
+++ b/ocamldoc/odoc_latex.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_latex.ml,v 1.36.2.1 2004/07/09 10:42:09 guesdon Exp $ *)
 
 (** Generation of LaTeX documentation. *)
 
@@ -22,6 +23,35 @@ open Exception
 open Class 
 open Module
 
+let new_buf () = Buffer.create 1024
+let new_fmt () =
+  let b = new_buf () in
+  let fmt = Format.formatter_of_buffer b in
+  (fmt,
+   fun () -> 
+    Format.pp_print_flush fmt ();
+    let s = Buffer.contents b in
+    Buffer.reset b;
+    s
+  )
+
+let p = Format.fprintf
+let ps f s = Format.fprintf f "%s" s
+
+
+let bp = Printf.bprintf
+let bs = Buffer.add_string
+
+let print_concat fmt sep f =
+  let rec iter = function
+      [] -> ()
+    | [c] -> f c
+    | c :: q ->
+	f c;
+	ps fmt sep;
+	iter q
+  in
+  iter
 
 (** Generation of LaTeX code from text structures. *)
 class text =
@@ -184,109 +214,140 @@ class text =
     (** Return latex code for the ref to a given label. *)
     method make_ref label = "\\ref{"^label^"}"
 
-    (** Return the LaTeX code corresponding to the [text] parameter.*)
-    method latex_of_text t = String.concat "" (List.map self#latex_of_text_element t)
+    (** Print the LaTeX code corresponding to the [text] parameter.*)
+    method latex_of_text fmt t = 
+      List.iter (self#latex_of_text_element fmt) t
         
-    (** Return the LaTeX code for the [text_element] in parameter. *)
-    method latex_of_text_element te =
+    (** Print the LaTeX code for the [text_element] in parameter. *)
+    method latex_of_text_element fmt te =
       match te with
-      | Odoc_info.Raw s -> self#latex_of_Raw s
-      | Odoc_info.Code s -> self#latex_of_Code s
-      | Odoc_info.CodePre s -> self#latex_of_CodePre s
-      | Odoc_info.Verbatim s -> self#latex_of_Verbatim s
-      | Odoc_info.Bold t -> self#latex_of_Bold t
-      | Odoc_info.Italic t -> self#latex_of_Italic t 
-      | Odoc_info.Emphasize t -> self#latex_of_Emphasize t
-      | Odoc_info.Center t -> self#latex_of_Center t
-      | Odoc_info.Left t -> self#latex_of_Left t
-      | Odoc_info.Right t -> self#latex_of_Right t
-      | Odoc_info.List tl -> self#latex_of_List tl
-      | Odoc_info.Enum tl -> self#latex_of_Enum tl
-      | Odoc_info.Newline -> self#latex_of_Newline
-      | Odoc_info.Block t -> self#latex_of_Block t
-      | Odoc_info.Title (n, l_opt, t) -> self#latex_of_Title n l_opt t
-      | Odoc_info.Latex s -> self#latex_of_Latex s
-      | Odoc_info.Link (s, t) -> self#latex_of_Link s t
-      | Odoc_info.Ref (name, ref_opt) -> self#latex_of_Ref name ref_opt
-      | Odoc_info.Superscript t -> self#latex_of_Superscript t
-      | Odoc_info.Subscript t -> self#latex_of_Subscript t
-            
-    method latex_of_Raw s = self#escape s
-
-    method latex_of_Code s = 
+      | Odoc_info.Raw s -> self#latex_of_Raw fmt s
+      | Odoc_info.Code s -> self#latex_of_Code fmt s
+      | Odoc_info.CodePre s -> self#latex_of_CodePre fmt s
+      | Odoc_info.Verbatim s -> self#latex_of_Verbatim fmt s
+      | Odoc_info.Bold t -> self#latex_of_Bold fmt t
+      | Odoc_info.Italic t -> self#latex_of_Italic fmt t 
+      | Odoc_info.Emphasize t -> self#latex_of_Emphasize fmt t
+      | Odoc_info.Center t -> self#latex_of_Center fmt t
+      | Odoc_info.Left t -> self#latex_of_Left fmt t
+      | Odoc_info.Right t -> self#latex_of_Right fmt t
+      | Odoc_info.List tl -> self#latex_of_List fmt tl
+      | Odoc_info.Enum tl -> self#latex_of_Enum fmt tl
+      | Odoc_info.Newline -> self#latex_of_Newline fmt
+      | Odoc_info.Block t -> self#latex_of_Block fmt t
+      | Odoc_info.Title (n, l_opt, t) -> self#latex_of_Title fmt n l_opt t
+      | Odoc_info.Latex s -> self#latex_of_Latex fmt s
+      | Odoc_info.Link (s, t) -> self#latex_of_Link fmt s t
+      | Odoc_info.Ref (name, ref_opt) -> self#latex_of_Ref fmt name ref_opt
+      | Odoc_info.Superscript t -> self#latex_of_Superscript fmt t
+      | Odoc_info.Subscript t -> self#latex_of_Subscript fmt t
+      |	Odoc_info.Module_list _ -> ()
+      |	Odoc_info.Index_list -> ()
+
+    method latex_of_Raw fmt s = 
+      ps fmt (self#escape s)
+
+    method latex_of_Code fmt s = 
       let s2 = self#escape_code s in
       let s3 = Str.global_replace (Str.regexp "\n") ("\\\\\n") s2 in
-      "{\\tt{"^s3^"}}"
-
-    method latex_of_CodePre s =
-      "\\begin{ocamldoccode}\n"^(self#escape_simple s)^"\n\\end{ocamldoccode}\n"
-
-    method latex_of_Verbatim s = "\\begin{verbatim}"^s^"\\end{verbatim}"
-
-    method latex_of_Bold t =
-      let s = self#latex_of_text t in
-      "{\\bf "^s^"}"
-
-    method latex_of_Italic t = 
-      let s = self#latex_of_text t in
-      "{\\it "^s^"}"
-
-    method latex_of_Emphasize t =
-      let s = self#latex_of_text t in
-      "{\\em "^s^"}"
-
-    method latex_of_Center t =
-      let s = self#latex_of_text t in
-      "\\begin{center}\n"^s^"\\end{center}\n"
-
-    method latex_of_Left t =
-      let s = self#latex_of_text t in
-      "\\begin{flushleft}\n"^s^"\\end{flushleft}\n"
-
-    method latex_of_Right t =
-      let s = self#latex_of_text t in
-      "\\begin{flushright}\n"^s^"\\end{flushright}\n"
-
-    method latex_of_List tl =
-      "\\begin{itemize}"^
-      (String.concat ""
-         (List.map (fun t -> "\\item "^(self#latex_of_text t)^"\n") tl))^
-      "\\end{itemize}\n"
-
-    method latex_of_Enum tl =
-      "\\begin{enumerate}"^
-      (String.concat ""
-         (List.map (fun t -> "\\item "^(self#latex_of_text t)^"\n") tl))^
-      "\\end{enumerate}\n"
-
-    method latex_of_Newline = "\n\n"
-
-    method latex_of_Block t =
-      let s = self#latex_of_text t in
-      "\\begin{ocamldocdescription}\n"^s^"\n\\end{ocamldocdescription}\n"
-
-    method latex_of_Title n label_opt t =
-      let s_title = self#latex_of_text t in
-      let s_title2 = self#section_style n s_title in
-      s_title2^
-      (match label_opt with
-        None -> ""
-      | Some l -> self#make_label (self#label ~no_: false l))
+      p fmt "{\\tt{%s}}" s3
+
+    method latex_of_CodePre fmt s =
+      ps fmt "\\begin{ocamldoccode}\n";
+      ps fmt (self#escape_simple s);
+      ps fmt "\n\\end{ocamldoccode}\n"
+
+    method latex_of_Verbatim fmt s = 
+      ps fmt "\\begin{verbatim}";
+      ps fmt s;
+      ps fmt "\\end{verbatim}"
+
+    method latex_of_Bold fmt t =
+      ps fmt "{\\bf ";
+      self#latex_of_text fmt t;
+      ps fmt "}"
+
+    method latex_of_Italic fmt t = 
+      ps fmt "{\\it ";
+      self#latex_of_text fmt t;
+      ps fmt "}"
+
+    method latex_of_Emphasize fmt t =
+      ps fmt "{\\em ";
+      self#latex_of_text fmt t;
+      ps fmt "}"
+
+    method latex_of_Center fmt t =
+      ps fmt "\\begin{center}\n";
+      self#latex_of_text fmt t;
+      ps fmt "\\end{center}\n"
+
+    method latex_of_Left fmt t =
+      ps fmt "\\begin{flushleft}\n";
+      self#latex_of_text fmt t;
+      ps fmt "\\end{flushleft}\n"
+
+    method latex_of_Right fmt t =
+      ps fmt "\\begin{flushright}\n";
+      self#latex_of_text fmt t;
+      ps fmt "\\end{flushright}\n"
+
+    method latex_of_List fmt tl =
+      ps fmt "\\begin{itemize}\n";
+      List.iter 
+	(fun t -> 
+	  ps fmt "\\item ";
+	  self#latex_of_text fmt t;
+	  ps fmt "\n"
+	) 
+	tl;
+      ps fmt "\\end{itemize}\n"
+
+    method latex_of_Enum fmt tl =
+      ps fmt "\\begin{enumerate}\n";
+      List.iter 
+	(fun t -> 
+	  ps fmt "\\item ";
+	  self#latex_of_text fmt t;
+	  ps fmt "\n"
+	) 
+	tl;
+      ps fmt "\\end{enumerate}\n"
+
+    method latex_of_Newline fmt = ps fmt "\n\n"
+
+    method latex_of_Block fmt t =
+      ps fmt "\\begin{ocamldocdescription}\n";
+      self#latex_of_text fmt t;
+      ps fmt "\n\\end{ocamldocdescription}\n"
+
+    method latex_of_Title fmt n label_opt t =
+      let (fmt2, flush) = new_fmt () in
+      self#latex_of_text fmt2 t;
+      let s_title2 = self#section_style n (flush ()) in
+      ps fmt s_title2;
+      (
+       match label_opt with
+         None -> ()
+       | Some l ->
+	   ps fmt (self#make_label (self#label ~no_: false l))
+      )
 
-    method latex_of_Latex s = s
+    method latex_of_Latex fmt s = ps fmt s
 
-    method latex_of_Link s t =
-      let s1 = self#latex_of_text t in
-      let s2 = "[\\url{"^s^"}]" in
-      s1^s2
+    method latex_of_Link fmt s t =
+      self#latex_of_text fmt t ;
+      ps fmt "[\\url{";
+      ps fmt s ;
+      ps fmt "}]"
 
-    method latex_of_Ref name ref_opt =
+    method latex_of_Ref fmt name ref_opt =
       match ref_opt with
         None -> 
-          self#latex_of_text_element 
+          self#latex_of_text_element fmt
             (Odoc_info.Code (Odoc_info.use_hidden_modules name))
       | Some (RK_section _) -> 
-          self#latex_of_text_element
+          self#latex_of_text_element fmt
             (Latex ("["^(self#make_ref (self#label ~no_:false (Name.simple name)))^"]"))
       | Some kind ->
           let f_label = 
@@ -302,16 +363,21 @@ class text =
             | Odoc_info.RK_method -> self#method_label
             | Odoc_info.RK_section _ -> assert false
           in
-          (self#latex_of_text 
-             [
-               Odoc_info.Code (Odoc_info.use_hidden_modules name) ;
-               Latex ("["^(self#make_ref (f_label name))^"]")
-             ] 
-          )
-
-    method latex_of_Superscript t = "$^{"^(self#latex_of_text t)^"}$"
-
-    method latex_of_Subscript t = "$_{"^(self#latex_of_text t)^"}$"
+          self#latex_of_text fmt
+            [
+              Odoc_info.Code (Odoc_info.use_hidden_modules name) ;
+              Latex ("["^(self#make_ref (f_label name))^"]")
+            ] 
+
+    method latex_of_Superscript fmt t = 
+      ps fmt "$^{";
+      self#latex_of_text fmt t;
+      ps fmt "}$"
+
+    method latex_of_Subscript fmt t = 
+      ps fmt "$_{";
+      self#latex_of_text fmt t;
+      ps fmt "}$"
 
   end
 
@@ -319,15 +385,15 @@ class text =
 class virtual info =
   object (self)
     (** The method used to get LaTeX code from a [text]. *)
-    method virtual latex_of_text : Odoc_info.text -> string
+    method virtual latex_of_text : Format.formatter -> Odoc_info.text -> unit
 
     (** The method used to get a [text] from an optionel info structure. *)
     method virtual text_of_info : ?block: bool -> Odoc_info.info option -> Odoc_info.text 
 
-    (** Return LaTeX code for a description, except for the [i_params] field. *)
-    method latex_of_info info_opt = 
-      self#latex_of_text 
-        (self#text_of_info ~block: false info_opt)
+    (** Print LaTeX code for a description, except for the [i_params] field. *)
+    method latex_of_info fmt ?(block=false) info_opt = 
+      self#latex_of_text fmt 
+        (self#text_of_info ~block info_opt)
   end
 
 (** This class is used to create objects which can generate a simple LaTeX documentation. *)
@@ -355,78 +421,68 @@ class latex =
                 let (_, rest) = Odoc_info.first_sentence_and_rest_of_text (self#text_of_info ~block: false i_opt) in
                 (Odoc_info.text_no_title_no_list first, rest)
 
-    (** Return LaTeX code for a value. *)
-    method latex_of_value v = 
+    (** Print LaTeX code for a value. *)
+    method latex_of_value fmt v = 
       Odoc_info.reset_type_names () ;
-      self#latex_of_text 
-        ((Latex (self#make_label (self#value_label v.val_name))) :: 
+      let label = self#value_label v.val_name in
+      let latex = self#make_label label in
+      self#latex_of_text fmt
+        ((Latex latex) :: 
          (to_text#text_of_value v))
 
-    (** Return LaTeX code for a class attribute. *)
-    method latex_of_attribute a =
-      self#latex_of_text 
+    (** Print LaTeX code for a class attribute. *)
+    method latex_of_attribute fmt a =
+      self#latex_of_text fmt
         ((Latex (self#make_label (self#attribute_label a.att_value.val_name))) :: 
          (to_text#text_of_attribute a))
 
-    (** Return LaTeX code for a class method. *)
-    method latex_of_method m = 
-      self#latex_of_text
+    (** Print LaTeX code for a class method. *)
+    method latex_of_method fmt m = 
+      self#latex_of_text fmt
         ((Latex (self#make_label (self#method_label m.met_value.val_name))) :: 
          (to_text#text_of_method m))
 
-    (** Return LaTeX code for the parameters of a type. *)
-    method latex_of_type_params m_name t =
-      let f (p, co, cn) =
-	Printf.sprintf "%s%s"
-	  (Odoc_info.string_of_variance t (co,cn))
-	  (self#normal_type m_name p)
+    (** Print LaTeX code for the parameters of a type. *)
+    method latex_of_type_params fmt m_name t =
+      let print_one (p, co, cn) =
+	ps fmt (Odoc_info.string_of_variance t (co,cn));
+	ps fmt (self#normal_type m_name p)
       in
       match t.ty_parameters with
-        [] -> ""
-      | [(p,co,cn)] -> f (p, co, cn)
+        [] -> ()
+      | [(p,co,cn)] -> print_one (p, co, cn)
       | l -> 
-	  Printf.sprintf "(%s)"
-	    (String.concat ", " (List.map f t.ty_parameters))
+	  ps fmt "(";
+	  print_concat fmt ", " print_one t.ty_parameters;
+	  ps fmt ")"
 
-    (** Return LaTeX code for a type. *)
-    method latex_of_type t =
+    (** Print LaTeX code for a type. *)
+    method latex_of_type fmt t =
       let s_name = Name.simple t.ty_name in
       let text = 
+	let (fmt2, flush2) = new_fmt () in
         Odoc_info.reset_type_names () ;
         let mod_name = Name.father t.ty_name in
-        let s_type1 = 
-          Format.fprintf Format.str_formatter "@[type ";
-          Format.fprintf Format.str_formatter "%s%s" 
-	    (self#latex_of_type_params mod_name t)
-	    (match t.ty_parameters with [] -> "" | _ -> " ");
-	  Format.flush_str_formatter ()
-        in
-        Format.fprintf Format.str_formatter 
-          ("@[%s %s")
-          s_type1
-          s_name;
-        let s_type2 = 
-	  (
-           match t.ty_manifest with
-             None -> ()
-           | Some typ -> 
-               Format.fprintf Format.str_formatter 
-		 " = %s"
-		 (self#normal_type mod_name typ)
-	  );
-	  Format.flush_str_formatter ()
-        in
+        Format.fprintf fmt2 "@[type ";
+	self#latex_of_type_params fmt2 mod_name t;
+	(match t.ty_parameters with [] -> () | _ -> ps fmt2 " ");
+        ps fmt2 s_name;
+	(
+         match t.ty_manifest with
+           None -> ()
+         | Some typ -> 
+             p fmt2 " = %s" (self#normal_type mod_name typ)
+	);
         let s_type3 = 
-          Format.fprintf Format.str_formatter 
-            ("%s %s")
-            s_type2
+          p fmt2
+            " %s"
             (
 	     match t.ty_kind with
                Type_abstract -> ""
              | Type_variant (_, priv) -> "="^(if priv then " private" else "")
              | Type_record (_, priv) -> "= "^(if priv then "private " else "")^"{" 
 	    ) ;
-          Format.flush_str_formatter ()
+          flush2 ()
         in
         
         let defs = 
@@ -437,28 +493,28 @@ class latex =
                (List.map
                   (fun constr ->
                     let s_cons = 
-                      Format.fprintf Format.str_formatter 
-                        "@[  | %s"
-                        constr.vc_name;
+                      p fmt2 "@[  | %s" constr.vc_name;
                       (
 		       match constr.vc_args with
                          [] -> ()
                        | l -> 
-                           Format.fprintf Format.str_formatter " %s@ %s" 
+                           p fmt2 " %s@ %s" 
 			     "of"
-                             (self#normal_type_list mod_name " * " l)
+                             (self#normal_type_list ~par: false mod_name " * " l)
 		      );
-		      Format.flush_str_formatter ()
+		      flush2 ()
                     in
                     [ CodePre s_cons ] @
                     (match constr.vc_text with
                       None -> []
                     | Some t -> 
-                        [ Latex
-                            ("\\begin{ocamldoccomment}\n"^
-                             (self#latex_of_text t)^
-                             "\n\\end{ocamldoccomment}\n")
-                        ] 
+			let s = 
+			  ps fmt2 "\\begin{ocamldoccomment}\n";
+			  self#latex_of_text fmt2 t;
+			  ps fmt2 "\n\\end{ocamldoccomment}\n";
+			  flush2 ()
+			in
+                        [ Latex s]
                     )
                   )
                   l
@@ -469,22 +525,24 @@ class latex =
                  (List.map
                     (fun r ->
                       let s_field = 
-                        Format.fprintf Format.str_formatter 
-                          "@[  %s%s :@ %s ;"
+                        p fmt2
+			  "@[  %s%s :@ %s ;"
                           (if r.rf_mutable then "mutable " else "")
                           r.rf_name
                           (self#normal_type mod_name r.rf_type);
-			Format.flush_str_formatter ()
+			flush2 ()
                       in
                       [ CodePre s_field ] @
                       (match r.rf_text with
                         None -> []
                       | Some t -> 
-                          [ Latex
-                              ("\\begin{ocamldoccomment}\n"^
-                               (self#latex_of_text t)^
-                               "\n\\end{ocamldoccomment}\n")
-                          ] 
+                          let s = 
+			    ps fmt2 "\\begin{ocamldoccomment}\n";
+			    self#latex_of_text fmt2 t;
+			    ps fmt2 "\n\\end{ocamldoccomment}\n";
+			    flush2 ()
+			in
+                        [ Latex s]
                       )
                     )
                     l
@@ -502,195 +560,401 @@ class latex =
               e :: (iter q)
         in
         (iter defs2) @
-        [Latex ("\\index{"^(self#type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
+        [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
         (self#text_of_info t.ty_info)
       in
-      self#latex_of_text 
+      self#latex_of_text fmt
         ((Latex (self#make_label (self#type_label t.ty_name))) :: text)
 
-    (** Return LaTeX code for an exception. *)
-    method latex_of_exception e =
+    (** Print LaTeX code for an exception. *)
+    method latex_of_exception fmt e =
       Odoc_info.reset_type_names () ;
-      self#latex_of_text 
+      self#latex_of_text fmt
         ((Latex (self#make_label (self#exception_label e.ex_name))) :: 
          (to_text#text_of_exception e))
 
-    (** Return the LaTeX code for the given module. 
-       @param for_detail indicate if we must print the type ([false]) or just ["sig"] ([true]).*)
-    method latex_of_module ?(for_detail=false) ?(with_link=true) m =
-      let buf = Buffer.create 32 in
-      let f = Format.formatter_of_buffer buf in
-      let father = Name.father m.m_name in
-      let t = 
-        Format.fprintf f "module %s" (Name.simple m.m_name);
-        Format.fprintf f " : %s"
-          (
-	   if for_detail 
-	   then "sig" 
-	   else (self#normal_module_type father m.m_type)
+    method latex_of_module_parameter fmt m_name p =
+      self#latex_of_text fmt 
+	[
+	  Code "functor (";
+	  Code p.mp_name ;
+	  Code " : ";
+	] ;
+      self#latex_of_module_type_kind fmt m_name p.mp_kind;
+      self#latex_of_text fmt [ Code ") -> "]
+
+
+    method latex_of_module_type_kind fmt father kind =
+      match kind with
+	Module_type_struct eles ->
+	  self#latex_of_text fmt [Latex "\\begin{ocamldocsigend}\n"];
+	  List.iter (self#latex_of_module_element fmt father) eles;
+	  self#latex_of_text fmt [Latex "\\end{ocamldocsigend}\n"]
+      | Module_type_functor (p, k) ->
+	  self#latex_of_module_parameter fmt father p;
+	  self#latex_of_module_type_kind fmt father k
+      | Module_type_alias a ->
+	  self#latex_of_text fmt 
+	    [Code (self#relative_module_idents father a.mta_name)]
+      | Module_type_with (k, s) ->
+	  self#latex_of_module_type_kind fmt father k;
+	  self#latex_of_text fmt 
+	    [ Code " "; 
+	      Code (self#relative_idents father s);
+	    ]
+	    
+    method latex_of_module_kind fmt father kind =
+      match kind with
+	Module_struct eles ->
+	  self#latex_of_text fmt [Latex "\\begin{ocamldocsigend}\n"];
+	  List.iter (self#latex_of_module_element fmt father) eles;
+	  self#latex_of_text fmt [Latex "\\end{ocamldocsigend}\n"]
+      | Module_alias a ->
+	  self#latex_of_text fmt 
+	    [Code (self#relative_module_idents father a.ma_name)]
+      | Module_functor (p, k) ->
+	  self#latex_of_module_parameter fmt father p;
+	  self#latex_of_module_kind fmt father k
+      | Module_apply (k1, k2) ->
+	  (* TODO: l'application n'est pas correcte dans un .mli. 
+	     Que faire ? -> afficher le module_type du typedtree  *)
+	  self#latex_of_module_kind fmt father k1;
+	  self#latex_of_text fmt [Code "("];
+	  self#latex_of_module_kind fmt father k2;
+	  self#latex_of_text fmt [Code ")"]
+      | Module_with (k, s) ->
+	  (* TODO: à modifier quand Module_with sera plus détaillé *)
+	  self#latex_of_module_type_kind fmt father k;
+	  self#latex_of_text fmt 
+	    [ Code " "; 
+	      Code (self#relative_idents father s) ;
+	    ]
+      | Module_constraint (k, tk) ->
+	  (* TODO: on affiche quoi ? *)
+	  self#latex_of_module_kind fmt father k
+
+    method latex_of_class_parameter fmt father p =
+      ps fmt (self#normal_type father (Parameter.typ p))
+
+    method latex_of_class_parameter_list fmt father params =
+      List.iter
+	(fun p -> 
+	  self#latex_of_class_parameter fmt father p;
+	  ps fmt " -> ")
+	params
+
+    method latex_of_class_kind fmt father kind =
+      match kind with
+        Class_structure (inh, eles) -> 
+	  self#latex_of_text fmt [Latex "\\begin{ocamldocobjectend}\n"];
+	  self#generate_inheritance_info fmt inh;
+	  List.iter (self#latex_of_class_element fmt father) eles;
+	  self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
+
+      | Class_apply capp ->
+	  (* TODO: afficher le type final à partir du typedtree *)
+	  self#latex_of_text fmt [Raw "class application not handled yet"]
+            
+      | Class_constr cco ->
+	  (
+           match cco.cco_type_parameters with
+             [] -> ()
+           | l -> 
+               self#latex_of_text fmt
+		 (
+		  Code "[" ::
+		  (self#text_of_class_type_param_expr_list father l) @
+		  [Code "] "]
+		 )
 	  );
-          
-        Format.pp_print_flush f ();
+	  self#latex_of_text fmt
+	    [Code (self#relative_idents father cco.cco_name)]
+
+      | Class_constraint (ck, ctk) ->
+          self#latex_of_text fmt [Code "( "] ;
+          self#latex_of_class_kind fmt father ck;
+          self#latex_of_text fmt [Code " : "] ;
+          self#latex_of_class_type_kind fmt father ctk;
+          self#latex_of_text fmt [Code " )"]
+
+    method latex_of_class_type_kind fmt father kind =
+      match kind with
+        Class_type cta -> 
+          (
+           match cta.cta_type_parameters with
+             [] -> ()
+           | l -> 
+               self#latex_of_text fmt 
+		 (Code "[" ::
+		  (self#text_of_class_type_param_expr_list father l) @
+		  [Code "] "]
+		 )
+          );
+          self#latex_of_text fmt
+	    [Code (self#relative_idents father cta.cta_name)]
+
+      | Class_signature (inh, eles) -> 
+	  self#latex_of_text fmt [Latex "\\begin{ocamldocobjectend}\n"];
+	  self#generate_inheritance_info fmt inh;
+	  List.iter (self#latex_of_class_element fmt father) eles;
+	  self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
+
+    method latex_for_module_index fmt m =
+      let s_name = Name.simple m.m_name in
+      self#latex_of_text fmt 
+	[Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+		(self#label ~no_:false s_name)^"`}\n"
+	       )
+	]
 
-        (CodePre (Buffer.contents buf)) ::
-        (
-         if with_link 
-         then [Odoc_info.Latex ("\\\n["^(self#make_ref (self#module_label m.m_name))^"]")]
-         else [] 
-        )
-      in
-      self#latex_of_text t
+    method latex_for_module_type_index fmt mt =
+      let s_name = Name.simple mt.mt_name in
+      self#latex_of_text fmt 
+	[Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+		(self#label ~no_:false (Name.simple s_name))^"`}\n"
+	       )
+	]
 
-    (** Return the LaTeX code for the given module type. 
-       @param for_detail indicate if we must print the type ([false]) or just ["sig"] ([true]).*)
-    method latex_of_module_type ?(for_detail=false) ?(with_link=true) mt =
-      let buf = Buffer.create 32 in
-      let f = Format.formatter_of_buffer buf in
-      let father = Name.father mt.mt_name in
-      let t = 
-        Format.fprintf f "module type %s" (Name.simple mt.mt_name);
-        (match mt.mt_type with
-          None -> ()
-        | Some mtyp -> 
-            Format.fprintf f " = %s"
-              (
-	       if for_detail 
-	       then "sig" 
-	       else (self#normal_module_type father mtyp)
-	      )
-        );
+    method latex_for_module_label fmt m =
+      ps fmt (self#make_label (self#module_label m.m_name))
 
-        Format.pp_print_flush f ();
+    method latex_for_module_type_label fmt mt =
+      ps fmt (self#make_label (self#module_type_label mt.mt_name))
 
-        (CodePre (Buffer.contents buf)) ::
-        (
-         if with_link 
-         then [Odoc_info.Latex ("\\\n["^(self#make_ref (self#module_type_label mt.mt_name))^"]")]
-         else [] 
-        )
+
+    method latex_for_class_index fmt c =
+      let s_name = Name.simple c.cl_name in
+      self#latex_of_text fmt 
+	[Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+		(self#label ~no_:false s_name)^"`}\n"
+	       )
+	]
+
+    method latex_for_class_type_index fmt ct =
+      let s_name = Name.simple ct.clt_name in
+      self#latex_of_text fmt 
+	[Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+		(self#label ~no_:false s_name)^"`}\n"
+	       )
+	]
+
+    method latex_for_class_label fmt c =
+      ps fmt (self#make_label (self#class_label c.cl_name))
+
+    method latex_for_class_type_label fmt ct =
+      ps fmt (self#make_label (self#class_type_label ct.clt_name))
+
+    (** Print the LaTeX code for the given module. *)
+    method latex_of_module fmt m =
+      let father = Name.father m.m_name in
+      let t = 
+        [
+	  Latex "\\begin{ocamldoccode}\n" ;
+	  Code "module ";
+	  Code (Name.simple m.m_name);
+          Code " : ";
+	]
       in
-      self#latex_of_text t
-
-    (** Return the LaTeX code for the given included module. *)
-    method latex_of_included_module im =
-      (self#latex_of_text [ Code "include module " ; 
-                            Code 
-                              (match im.im_module with
-                                None -> im.im_name
-                              | Some (Mod m) -> m.m_name
-                              | Some (Modtype mt) -> mt.mt_name)
-                          ] )
-
-    (** Return the LaTeX code for the given class. 
-       @param for_detail indicate if we must print the type ([false]) or just ["object"] ([true]).*)
-    method latex_of_class ?(for_detail=false) ?(with_link=true) c =
+      self#latex_of_text fmt t;
+      self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
+      self#latex_for_module_label fmt m;
+      self#latex_for_module_index fmt m;
+      p fmt "@[";
+      self#latex_of_module_kind fmt father m.m_kind;
+      (
+       match Module.module_is_functor m with
+	 false -> ()
+       | true ->
+	   self#latex_of_text fmt  [Newline];
+	   (
+	    match List.filter (fun (_,d) -> d <> None)
+		(module_parameters ~trans: false m)
+	    with
+	      [] -> ()
+	    | l ->
+		let t = 
+		  [ Bold [Raw "Parameters: "];
+		    List
+		      (List.map
+			 (fun (p,text_opt) ->
+			   let t = match text_opt with None -> [] | Some t -> t in
+			   ( Raw p.mp_name :: Raw ": " :: t)
+			 )
+			 l
+		      )
+		  ]
+	   in
+	   self#latex_of_text fmt t
+	   );
+      );
+      self#latex_of_text fmt [Newline];
+      self#latex_of_info fmt ~block: true m.m_info;
+      p fmt "@]";
+
+
+    (** Print the LaTeX code for the given module type. *)
+    method latex_of_module_type fmt mt =
+      let father = Name.father mt.mt_name in
+      let t = 
+        [
+	  Latex "\\begin{ocamldoccode}\n" ;
+	  Code "module type " ;
+	  Code (Name.simple mt.mt_name);
+	] 
+      in
+      self#latex_of_text fmt t;
+      (
+       match mt.mt_type, mt.mt_kind with
+       | Some mtyp, Some kind -> 
+           self#latex_of_text fmt [ Code " = " ];
+	   self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
+	   self#latex_for_module_type_label fmt mt;
+	   self#latex_for_module_type_index fmt mt;
+	   p fmt "@[";
+	   self#latex_of_module_type_kind fmt father kind
+       | _ ->
+	   self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
+	   self#latex_for_module_type_index fmt mt;
+	   p fmt "@[";
+      );
+      (
+       match Module.module_type_is_functor mt with
+	 false -> ()
+       | true ->
+	   self#latex_of_text fmt [Newline];
+	   (
+	    match List.filter (fun (_,d) -> d <> None)
+		(module_type_parameters ~trans: false mt)
+	    with
+	      [] -> ()
+	    | l ->
+		let t = 
+		  [ Bold [Raw "Parameters: "];
+		    List
+		      (List.map
+			 (fun (p,text_opt) ->
+			   let t = match text_opt with None -> [] | Some t -> t in
+			   ( Raw p.mp_name :: Raw ": " :: t)
+			 )
+			 l
+		      )
+		  ] 
+		in
+		self#latex_of_text fmt t
+	   );
+      );
+      self#latex_of_text fmt [Newline];
+      self#latex_of_info fmt ~block: true mt.mt_info;
+      p fmt "@]";
+
+    (** Print the LaTeX code for the given included module. *)
+    method latex_of_included_module fmt im =
+      self#latex_of_text fmt
+	((Code "include ") ::
+         (Code 
+            (match im.im_module with
+              None -> im.im_name
+            | Some (Mod m) -> m.m_name
+            | Some (Modtype mt) -> mt.mt_name)
+	 ) ::
+	 (self#text_of_info im.im_info)
+        )
+
+    (** Print the LaTeX code for the given class. *)
+    method latex_of_class fmt c =
       Odoc_info.reset_type_names () ;
-      let buf = Buffer.create 32 in
-      let f = Format.formatter_of_buffer buf in
       let father = Name.father c.cl_name in
+      let type_params =
+        match c.cl_type_parameters with
+          [] -> ""
+        | l -> (self#normal_class_type_param_list father l)^" "
+      in
       let t = 
-        Format.fprintf f "class %s" 
-          (if c.cl_virtual then "virtual " else "");
-        (
-         match c.cl_type_parameters with
-           [] -> ()
-         | l -> 
-             Format.fprintf f "[" ;
-             let s1 = self#normal_type_list father ", " l in
-             Format.fprintf f "%s] " s1
-        );
-        Format.fprintf f "%s : %s" 
-	  (Name.simple c.cl_name)
-          (
-	   if for_detail then
-	     "object"
-	   else
-	     self#normal_class_type father c.cl_type
-	  );
-
-        Format.pp_print_flush f ();
-        
-        (CodePre (Buffer.contents buf)) ::
-        (
-         if with_link 
-         then [Odoc_info.Latex (" ["^(self#make_ref (self#class_label c.cl_name))^"]")]
-         else [] 
-        ) 
+	[
+	  Latex "\\begin{ocamldoccode}\n" ;
+	  Code (Printf.sprintf
+		  "class %s%s%s : "
+		  (if c.cl_virtual then "virtual " else "")
+		  type_params
+		  (Name.simple c.cl_name)
+	       )
+	] 
       in
-      self#latex_of_text t
-
-    (** Return the LaTeX code for the given class type. 
-       @param for_detail indicate if we must print the type ([false]) or just ["object"] ([true]).*)
-    method latex_of_class_type ?(for_detail=false) ?(with_link=true) ct =
+      self#latex_of_text fmt t;
+      self#latex_of_class_parameter_list fmt father c.cl_parameters;
+      self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
+      self#latex_for_class_label fmt c;
+      self#latex_for_class_index fmt c;
+      p fmt "@[";
+      self#latex_of_class_kind fmt father c.cl_kind;
+      self#latex_of_text fmt [Newline];
+      self#latex_of_info fmt ~block: true c.cl_info;
+      p fmt "@]"
+
+    (** Print the LaTeX code for the given class type. *)
+    method latex_of_class_type fmt ct =
       Odoc_info.reset_type_names () ;
-      let buf = Buffer.create 32 in
-      let f = Format.formatter_of_buffer buf in
       let father = Name.father ct.clt_name in
+      let type_params =
+        match ct.clt_type_parameters with
+          [] -> ""
+        | l -> (self#normal_class_type_param_list father l)^" "
+      in
       let t = 
-        Format.fprintf f "class type %s" 
-          (if ct.clt_virtual then "virtual " else "");
-        (
-         match ct.clt_type_parameters with
-             [] -> ()
-         | l -> 
-             Format.fprintf f "[" ;
-             let s1 = self#normal_type_list father ", " l in
-             Format.fprintf f "%s] " s1
-        );
-        Format.fprintf f "%s = %s" 
-	  (Name.simple ct.clt_name)
-          (if for_detail then
-	    "object"
-	  else
-	    self#normal_class_type father ct.clt_type
-	  );
-
-        Format.pp_print_flush f ();
-        (CodePre (Buffer.contents buf)) ::
-        (
-         if with_link 
-         then [Odoc_info.Latex (" ["^(self#make_ref (self#class_type_label ct.clt_name))^"]")]
-         else [] 
-        ) 
+	[
+	  Latex "\\begin{ocamldoccode}\n" ;
+	  Code (Printf.sprintf
+		  "class type %s%s%s = "
+		  (if ct.clt_virtual then "virtual " else "")
+		  type_params
+		  (Name.simple ct.clt_name)
+	       )
+	] 
       in
-      self#latex_of_text t
-
-    (** Return the LaTeX code for the given class element. *)
-    method latex_of_class_element class_name class_ele =
-      (self#latex_of_text [Newline])^
-      (
-       match class_ele with
-         Class_attribute att -> self#latex_of_attribute att
-       | Class_method met -> self#latex_of_method met
-       | Class_comment t ->
-           match t with
-           | [] -> ""
-           | (Title (_,_,_)) :: _ -> self#latex_of_text t
-           | _ -> self#latex_of_text [ Title ((Name.depth class_name) + 2, None, t) ]
-      )
-
-    (** Return the LaTeX code for the given module element. *)
-    method latex_of_module_element module_name module_ele =
-      (self#latex_of_text [Newline])^
-      (
-       match module_ele with
-         Element_module m -> self#latex_of_module m
-       | Element_module_type mt -> self#latex_of_module_type mt
-       | Element_included_module im -> self#latex_of_included_module im
-       | Element_class c -> self#latex_of_class c
-       | Element_class_type ct -> self#latex_of_class_type ct
-       | Element_value v -> self#latex_of_value v
-       | Element_exception e -> self#latex_of_exception e
-       | Element_type t -> self#latex_of_type t
-       | Element_module_comment t -> self#latex_of_text t
-      )
+      self#latex_of_text fmt t;
+
+      self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
+      self#latex_for_class_type_label fmt ct;
+      self#latex_for_class_type_index fmt ct;
+      p fmt "@[";
+      self#latex_of_class_type_kind fmt father ct.clt_kind;
+      self#latex_of_text fmt [Newline];
+      self#latex_of_info fmt ~block: true ct.clt_info;
+      p fmt "@]"
+
+    (** Print the LaTeX code for the given class element. *)
+    method latex_of_class_element fmt class_name class_ele =
+      self#latex_of_text fmt [Newline];
+      match class_ele with
+        Class_attribute att -> self#latex_of_attribute fmt att
+      | Class_method met -> self#latex_of_method fmt met
+      | Class_comment t ->
+          match t with
+          | [] -> ()
+          | (Title (_,_,_)) :: _ -> self#latex_of_text fmt t
+          | _ -> self#latex_of_text fmt [ Title ((Name.depth class_name) + 2, None, t) ]
+
+    (** Print the LaTeX code for the given module element. *)
+    method latex_of_module_element fmt module_name module_ele =
+      self#latex_of_text fmt [Newline];
+      match module_ele with
+        Element_module m -> self#latex_of_module fmt m
+      | Element_module_type mt -> self#latex_of_module_type fmt mt
+      | Element_included_module im -> self#latex_of_included_module fmt im
+      | Element_class c -> self#latex_of_class fmt c
+      | Element_class_type ct -> self#latex_of_class_type fmt ct
+      | Element_value v -> self#latex_of_value fmt v
+      | Element_exception e -> self#latex_of_exception fmt e
+      | Element_type t -> self#latex_of_type fmt t
+      | Element_module_comment t -> self#latex_of_text fmt t
 
     (** Generate the LaTeX code for the given list of inherited classes.*)
-    method generate_inheritance_info chanout inher_l =
+    method generate_inheritance_info fmt inher_l =
       let f inh =
         match inh.ic_class with
           None -> (* we can't make the reference *)
-            (Odoc_info.Code inh.ic_name) ::
+	    Newline ::
+            Code ("inherit "^inh.ic_name) ::
             (match inh.ic_text with
               None -> []
             | Some t -> Newline :: t
@@ -702,29 +966,24 @@ class latex =
               | Cltype _ -> self#class_type_label inh.ic_name
             in
             (* we can create the reference *)
-            (Odoc_info.Code inh.ic_name) ::
+	    Newline ::
+            Odoc_info.Code ("inherit "^inh.ic_name) ::
             (Odoc_info.Latex (" ["^(self#make_ref label)^"]")) :: 
             (match inh.ic_text with
               None -> []
             | Some t -> Newline :: t
             )
       in
-      let text = [
-        Odoc_info.Bold [Odoc_info.Raw Odoc_messages.inherits ];
-        Odoc_info.List (List.map f inher_l)
-      ] 
-      in
-      let s = self#latex_of_text text in
-      output_string chanout s
+      List.iter (self#latex_of_text fmt) (List.map f inher_l)
 
     (** Generate the LaTeX code for the inherited classes of the given class. *)
-    method generate_class_inheritance_info chanout cl =
+    method generate_class_inheritance_info fmt cl =
       let rec iter_kind k = 
         match k with
           Class_structure ([], _) ->
             ()
         | Class_structure (l, _) ->
-            self#generate_inheritance_info chanout l
+            self#generate_inheritance_info fmt l
         | Class_constraint (k, _) ->
             iter_kind k
         | Class_apply _
@@ -734,182 +993,70 @@ class latex =
       iter_kind cl.cl_kind
 
     (** Generate the LaTeX code for the inherited classes of the given class type. *)
-    method generate_class_type_inheritance_info chanout clt =
+    method generate_class_type_inheritance_info fmt clt =
       match clt.clt_kind with
         Class_signature ([], _) ->
           ()
       | Class_signature (l, _) ->
-          self#generate_inheritance_info chanout l
+          self#generate_inheritance_info fmt l
       | Class_type _ ->
           ()
 
-    (** Generate the LaTeX code for the given class, in the given out channel. *)
-    method generate_for_class chanout c =
-      Odoc_info.reset_type_names () ;
-      let depth = Name.depth c.cl_name in
-      let (first_t, rest_t) = self#first_and_rest_of_info c.cl_info in
-      let text = [ Title (depth, None, [ Raw (Odoc_messages.clas^" ") ; Code c.cl_name ] @
-                          (match first_t with 
-                            [] -> []
-                          | t -> (Raw " : ") :: t)) ;
-                   Latex (self#make_label (self#class_label c.cl_name)) ;
-                 ] 
-      in
-      output_string chanout (self#latex_of_text text);
-      output_string chanout ((self#latex_of_class ~for_detail: true ~with_link: false c)^"\n\n") ;
-      let s_name = Name.simple c.cl_name in
-      output_string chanout
-        (self#latex_of_text [Latex ("\\index{"^(self#class_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]);
-      output_string chanout (self#latex_of_text rest_t) ;
-      (* parameters *)
-      output_string chanout 
-        (self#latex_of_text (self#text_of_parameter_list (Name.father c.cl_name) c.cl_parameters));
-       
-      output_string chanout (self#latex_of_text [ Newline ] );
-      output_string chanout ("\\ocamldocvspace{0.5cm}\n\n");
-      self#generate_class_inheritance_info chanout c;
-
-      List.iter 
-        (fun ele -> output_string chanout ((self#latex_of_class_element c.cl_name ele)^"\n\n"))
-        (Class.class_elements ~trans: false c);
-
-      output_string chanout (self#latex_of_text [ CodePre "end"])
-
-    (** Generate the LaTeX code for the given class type, in the given out channel. *)
-    method generate_for_class_type chanout ct =
-      Odoc_info.reset_type_names () ;
-      let depth = Name.depth ct.clt_name in
-      let (first_t, rest_t) = self#first_and_rest_of_info ct.clt_info in
-      let text = [ Title (depth, None, [ Raw (Odoc_messages.class_type^" ") ; Code ct.clt_name ] @
-                          (match first_t with 
-                            [] -> []
-                          | t -> (Raw " : ") :: t)) ;
-                   Latex (self#make_label (self#class_type_label ct.clt_name)) ;
-                 ] 
-      in
-
-      output_string chanout (self#latex_of_text text);
-      output_string chanout ((self#latex_of_class_type ~for_detail: true ~with_link: false ct)^"\n\n") ;
-      let s_name = Name.simple ct.clt_name in
-      output_string chanout
-        (self#latex_of_text [Latex ("\\index{"^(self#class_type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]);
-      output_string chanout ((self#latex_of_text rest_t)) ;
-      output_string chanout (self#latex_of_text [ Newline]) ;
-      output_string chanout ("\\ocamldocvspace{0.5cm}\n\n");
-      self#generate_class_type_inheritance_info chanout ct;
-
-      List.iter 
-        (fun ele -> output_string chanout ((self#latex_of_class_element ct.clt_name ele)^"\n\n"))
-        (Class.class_type_elements ~trans: false ct);
-
-      output_string chanout (self#latex_of_text [ CodePre "end"])
-
-    (** Generate the LaTeX code for the given module type, in the given out channel. *)
-    method generate_for_module_type chanout mt =
-      let depth = Name.depth mt.mt_name in
-      let (first_t, rest_t) = self#first_and_rest_of_info mt.mt_info in
-      let text = [ Title (depth,  None,
-                          [ Raw (Odoc_messages.module_type^" ") ; Code mt.mt_name ] @
-                          (match first_t with 
-                            [] -> []
-                          | t -> (Raw " : ") :: t)) ;
-                   Latex (self#make_label (self#module_type_label mt.mt_name)) ;
-                 ] 
-      in
-      output_string chanout (self#latex_of_text text);
-      if depth > 1 then
-        output_string chanout ((self#latex_of_module_type ~for_detail: true ~with_link: false mt)^"\n\n");
-      let s_name = Name.simple mt.mt_name in
-      output_string chanout
-        (self#latex_of_text [Latex ("\\index{"^(self#module_type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]);
-      output_string chanout (self#latex_of_text rest_t) ;
-      (* parameters *)
-      output_string chanout 
-        (self#latex_of_text 
-           (self#text_of_module_parameter_list
-              (Module.module_type_parameters mt)));
-
-      output_string chanout (self#latex_of_text [ Newline ] );
-      output_string chanout ("\\ocamldocvspace{0.5cm}\n\n");
-      List.iter 
-        (fun ele -> output_string chanout ((self#latex_of_module_element mt.mt_name ele)^"\n\n"))
-        (Module.module_type_elements ~trans: false mt);
-
-      if depth > 1 then 
-	output_string chanout (self#latex_of_text [ CodePre "end"]);
-
-      (* create sub parts for modules, module types, classes and class types *)
-      let rec iter ele =
-        match ele with
-          Element_module m -> self#generate_for_module chanout m
-        | Element_module_type mt -> self#generate_for_module_type chanout mt
-        | Element_class c -> self#generate_for_class chanout c
-        | Element_class_type ct -> self#generate_for_class_type chanout ct
-        | _ -> ()
-      in
-      List.iter iter (Module.module_type_elements ~trans: false mt)
-
-    (** Generate the LaTeX code for the given module, in the given out channel. *)
-    method generate_for_module chanout m =
-      let depth = Name.depth m.m_name in
+    (** Generate the LaTeX code for the given top module, in the given buffer. *)
+    method generate_for_top_module fmt m =
       let (first_t, rest_t) = self#first_and_rest_of_info m.m_info in
-      let text = [ Title (depth, None,
+      let text = [ Title (1, None,
                           [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] @
                           (match first_t with 
                             [] -> []
                           | t -> (Raw " : ") :: t)) ;
-                   Latex (self#make_label (self#module_label m.m_name)) ;
                  ] 
       in
-      output_string chanout (self#latex_of_text text);
-      if depth > 1 then
-        output_string chanout ((self#latex_of_module ~for_detail:true ~with_link: false m)^"\n\n");
-      let s_name = Name.simple m.m_name in
-      output_string chanout
-        (self#latex_of_text [Latex ("\\index{"^(self#module_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]);
-      output_string chanout (self#latex_of_text rest_t) ;
-      (* parameters *)
-      output_string chanout 
-        (self#latex_of_text 
-           (self#text_of_module_parameter_list
-              (Module.module_parameters m)));
-
-      output_string chanout (self#latex_of_text [ Newline ]) ;
-      output_string chanout ("\\ocamldocvspace{0.5cm}\n\n");
+      self#latex_of_text fmt text;
+      self#latex_for_module_label fmt m;
+      self#latex_for_module_index fmt m;
+      self#latex_of_text fmt rest_t ;
+
+      self#latex_of_text fmt [ Newline ] ;
+      ps fmt "\\ocamldocvspace{0.5cm}\n\n";
       List.iter 
-        (fun ele -> output_string chanout ((self#latex_of_module_element m.m_name ele)^"\n\n"))
-        (Module.module_elements ~trans: false m);
-
-      if depth > 1 then 
-	output_string chanout (self#latex_of_text [ CodePre "end"]);
-
-      (* create sub parts for modules, module types, classes and class types *)
-      let rec iter ele =
-        match ele with
-          Element_module m -> self#generate_for_module chanout m
-        | Element_module_type mt -> self#generate_for_module_type chanout mt
-        | Element_class c -> self#generate_for_class chanout c
-        | Element_class_type ct -> self#generate_for_class_type chanout ct
-        | _ -> ()
-      in
-      List.iter iter (Module.module_elements ~trans: false m)
-
-    (** Return the header of the TeX document. *)
-    method latex_header =
-      "\\documentclass[11pt]{article} \n"^
-      "\\usepackage[latin1]{inputenc} \n"^
-      "\\usepackage[T1]{fontenc} \n"^
-      "\\usepackage{fullpage} \n"^
-      "\\usepackage{url} \n"^
-      "\\usepackage{ocamldoc}\n"^
+        (fun ele -> 
+	  self#latex_of_module_element fmt m.m_name ele;
+	  ps fmt "\n\n"
+	)
+        (Module.module_elements ~trans: false m)
+
+    (** Print the header of the TeX document. *)
+    method latex_header fmt =
+      ps fmt "\\documentclass[11pt]{article} \n";
+      ps fmt "\\usepackage[latin1]{inputenc} \n";
+      ps fmt "\\usepackage[T1]{fontenc} \n";
+      ps fmt "\\usepackage{fullpage} \n";
+      ps fmt "\\usepackage{url} \n";
+      ps fmt "\\usepackage{ocamldoc}\n";
       (
        match !Args.title with 
-         None -> ""
-       | Some s -> "\\title{"^(self#escape s)^"}\n"
-      )^
-      "\\begin{document}\n"^
-      (match !Args.title with None -> "" | Some _ -> "\\maketitle\n")^
-      (if !Args.with_toc then "\\tableofcontents\n" else "")
+         None -> ()
+       | Some s -> 
+	   ps fmt "\\title{";
+	   ps fmt (self#escape s);
+	   ps fmt "}\n"
+      );
+      ps fmt "\\begin{document}\n";
+      (match !Args.title with 
+	None -> () | 
+	Some _ -> ps fmt "\\maketitle\n"
+      );
+      if !Args.with_toc then ps fmt "\\tableofcontents\n";
+      (
+       let info = Odoc_info.apply_opt
+	   Odoc_info.info_of_comment_file !Odoc_info.Args.intro_file 
+       in
+       (match info with None -> () | Some _ -> ps fmt "\\vspace{0.2cm}");
+       self#latex_of_info fmt info;
+       (match info with None -> () | Some _ -> ps fmt "\n\n")
+      )
+	
 
     (** Generate the LaTeX style file, if it does not exists. *)
     method generate_style_file =
@@ -934,14 +1081,18 @@ class latex =
     (** Generate the LaTeX file from a module list, in the {!Odoc_info.Args.out_file} file. *)
     method generate module_list =
       self#generate_style_file ;
+      let main_file = !Args.out_file in
+      let dir = Filename.dirname main_file in
       if !Args.separate_files then
         (
          let f m =
            try
              let chanout = 
-               open_out ((Filename.concat !Args.target_dir (Name.simple m.m_name))^".tex")
+               open_out ((Filename.concat dir (Name.simple m.m_name))^".tex")
              in
-             self#generate_for_module chanout m ;
+	     let fmt = Format.formatter_of_out_channel chanout in
+             self#generate_for_top_module fmt m ;
+	     Format.pp_print_flush fmt ();
              close_out chanout
            with
              Failure s
@@ -953,16 +1104,19 @@ class latex =
         );
       
       try
-        let chanout = open_out !Args.out_file in
-        let _ = if !Args.with_header then output_string chanout self#latex_header else () in
+        let chanout = open_out main_file in
+	let fmt = Format.formatter_of_out_channel chanout in
+        if !Args.with_header then self#latex_header fmt;
         List.iter 
-          (fun m -> if !Args.separate_files then
-            output_string chanout ("\\input{"^((Name.simple m.m_name))^".tex}\n")
-          else
-            self#generate_for_module chanout m
+          (fun m -> 
+	    if !Args.separate_files then
+              ps fmt ("\\input{"^((Name.simple m.m_name))^".tex}\n")
+            else
+              self#generate_for_top_module fmt m
           ) 
           module_list ;
-        let _ = if !Args.with_trailer then output_string chanout "\\end{document}" else () in
+        if !Args.with_trailer then ps fmt "\\end{document}";
+	Format.pp_print_flush fmt ();
         close_out chanout
       with
         Failure s
@@ -970,3 +1124,5 @@ class latex =
           prerr_endline s ;
           incr Odoc_info.errors 
   end
+
+(* eof $Id: odoc_latex.ml,v 1.36.2.1 2004/07/09 10:42:09 guesdon Exp $ *)
diff --git a/ocamldoc/odoc_latex_style.ml b/ocamldoc/odoc_latex_style.ml
index 34e81ffe..6b791c87 100644
--- a/ocamldoc/odoc_latex_style.ml
+++ b/ocamldoc/odoc_latex_style.ml
@@ -11,6 +11,8 @@
 
 (** The content of the LaTeX style to generate when generating LaTeX code. *)
 
+(* $Id: odoc_latex_style.ml,v 1.5 2004/06/11 14:25:50 guesdon Exp $ *)
+
 let content ="
 %% Support macros for LaTeX documentation generated by ocamldoc.
 %% This file is in the public domain; do what you want with it.
@@ -61,14 +63,30 @@ let content ="
   }
 
 \\newenvironment{ocamldocdescription}
-{\\list{}{\\rightmargin0pt \\topsep0pt}\\raggedright\\item\\relax}
+{\\list{}{\\rightmargin0pt \\topsep0pt}\\raggedright\\item\\noindent\\relax\\ignorespaces}
 {\\endlist\\medskip}
 
 \\newenvironment{ocamldoccomment}
-{\\list{}{\\leftmargin 2\\leftmargini \\rightmargin0pt \\topsep0pt}\\raggedright\\item\\relax}
+{\\list{}{\\leftmargin 2\\leftmargini \\rightmargin0pt \\topsep0pt}\\raggedright\\item\\noindent\\relax}
 {\\endlist}
 
+\\let \\ocamldocparagraph \\paragraph
+\\def \\paragraph #1{\\ocamldocparagraph {#1}\\noindent}
+\\let \\ocamldocsubparagraph \\subparagraph
+\\def \\subparagraph #1{\\ocamldocsubparagraph {#1}\\noindent}
+
 \\let\\ocamldocvspace\\vspace
+
+\\newenvironment{ocamldocindent}{\\list{}{}\\item\\relax}{\\endlist}
+\\newenvironment{ocamldocsigend}
+     {\\noindent\\quad\\texttt{sig}\\ocamldocindent}
+     {\\endocamldocindent\\vskip -\\lastskip
+      \\noindent\\quad\\texttt{end}\\medskip}
+\\newenvironment{ocamldocobjectend}
+     {\\noindent\\quad\\texttt{object}\\ocamldocindent}
+     {\\endocamldocindent\\vskip -\\lastskip
+      \\noindent\\quad\\texttt{end}\\medskip}
+
 \\endinput
 "
 
diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll
index acf7b4bd..7df10ce6 100644
--- a/ocamldoc/odoc_lexer.mll
+++ b/ocamldoc/odoc_lexer.mll
@@ -10,6 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_lexer.mll,v 1.4 2003/11/24 10:41:04 starynke Exp $ *)
+
 (** The lexer for special comments. *)
 
 open Lexing
diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml
index 10f85ca9..b4ed905d 100644
--- a/ocamldoc/odoc_man.ml
+++ b/ocamldoc/odoc_man.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_man.ml,v 1.22 2004/05/23 10:41:50 guesdon Exp $ *)
 
 (** The man pages generator. *)
 open Odoc_info 
@@ -20,6 +21,9 @@ open Class
 open Module
 open Search
 
+let new_buf () = Buffer.create 1024
+let bp = Printf.bprintf
+let bs = Buffer.add_string
 
 (** A class used to get a [text] for info structures. *)
 class virtual info =
@@ -30,76 +34,112 @@ class virtual info =
     val mutable tag_functions = ([] : (string * (Odoc_info.text -> string)) list)
 
     (** Return man code for a [text]. *)
-    method virtual man_of_text : Odoc_info.text -> string
+    method virtual man_of_text : Buffer.t -> Odoc_info.text -> unit
 
-    (** Groff string for an author list. *)
-    method man_of_author_list l =
+    (** Print groff string for an author list. *)
+    method man_of_author_list b l =
       match l with
-        [] ->
-          ""
+        [] -> ()
       | _ ->
-          ".B \""^Odoc_messages.authors^"\"\n:\n"^
-          (String.concat ", " l)^
-          "\n.sp\n"
-
-    (** Groff string for the given optional version information.*)
-    method man_of_version_opt v_opt =
+          bs b ".B \"";
+	  bs b Odoc_messages.authors;
+	  bs b "\"\n:\n";
+          bs b (String.concat ", " l);
+          bs b "\n.sp\n"
+
+    (** Print groff string for the given optional version information.*)
+    method man_of_version_opt b v_opt =
       match v_opt with
-        None -> ""
-      | Some v -> ".B \""^Odoc_messages.version^"\"\n:\n"^v^"\n.sp\n"
-
-    (** Groff string for the given optional since information.*)
-    method man_of_since_opt s_opt =
+        None -> ()
+      | Some v -> 
+	  bs b ".B \"";
+	  bs b Odoc_messages.version;
+	  bs b "\"\n:\n";
+	  bs b v;
+	  bs b "\n.sp\n"
+
+    (** Print groff string for the given optional since information.*)
+    method man_of_since_opt b s_opt =
       match s_opt with
-        None -> ""
-      | Some s -> ".B \""^Odoc_messages.since^"\"\n"^s^"\n.sp\n"
-
-    (** Groff string for the given list of raised exceptions.*)
-    method man_of_raised_exceptions l =
+        None -> ()
+      | Some s -> 
+	  bs b ".B \"";
+	  bs b Odoc_messages.since;
+	  bs b "\"\n";
+	  bs b s;
+	  bs b "\n.sp\n"
+
+    (** Print groff string for the given list of raised exceptions.*)
+    method man_of_raised_exceptions b l =
       match l with
-        [] -> ""
-      | (s, t) :: [] -> ".B \""^Odoc_messages.raises^" "^s^"\"\n"^(self#man_of_text t)^"\n.sp\n"
+        [] -> ()
+      | (s, t) :: [] -> 
+	  bs b ".B \"";
+	  bs b Odoc_messages.raises;
+	  bs b (" "^s^"\"\n");
+	  self#man_of_text b t;
+	  bs b "\n.sp\n"
       | _ ->
-          ".B \""^Odoc_messages.raises^"\"\n"^
-          (String.concat ""
-             (List.map
-                (fun (ex, desc) -> ".TP\n.B \""^ex^"\"\n"^(self#man_of_text desc)^"\n")
-                l
-             )
-          )^"\n.sp\n"
-
-    (** Groff string for the given "see also" reference. *)
-    method man_of_see (see_ref, t)  =
+          bs b ".B \"";
+	  bs b Odoc_messages.raises;
+	  bs b "\"\n";
+          List.iter
+            (fun (ex, desc) -> 
+	      bs b ".TP\n.B \"";
+	      bs b ex;
+	      bs b "\"\n";
+	      self#man_of_text b desc;
+	      bs b "\n"
+	    )
+            l;
+	  bs b "\n.sp\n"
+
+    (** Print groff string for the given "see also" reference. *)
+    method man_of_see b (see_ref, t)  =
       let t_ref = 
         match see_ref with
           Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ]
         | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t
         | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t
       in
-      self#man_of_text t_ref
+      self#man_of_text b t_ref
 
-    (** Groff string for the given list of "see also" references.*)
-    method man_of_sees l =
+    (** Print groff string for the given list of "see also" references.*)
+    method man_of_sees b l =
       match l with
-        [] -> ""
-      | see :: [] -> ".B \""^Odoc_messages.see_also^"\"\n"^(self#man_of_see see)^"\n.sp\n"
+        [] -> ()
+      | see :: [] -> 
+	  bs b ".B \"";
+	  bs b Odoc_messages.see_also;
+	  bs b "\"\n";
+	  self#man_of_see b see;
+	  bs b "\n.sp\n"
       | _ ->
-          ".B \""^Odoc_messages.see_also^"\"\n"^
-          (String.concat ""
-             (List.map
-                (fun see -> ".TP\n \"\"\n"^(self#man_of_see see)^"\n")
-                l
-             )
-          )^"\n.sp\n"
-
-    (** Groff string for the given optional return information.*)
-    method man_of_return_opt return_opt =
+          bs b ".B \"";
+	  bs b Odoc_messages.see_also;
+	  bs b "\"\n";
+	  List.iter
+            (fun see -> 
+	      bs b ".TP\n \"\"\n";
+	      self#man_of_see b see;
+	      bs b "\n"
+	    )
+            l;
+          bs b "\n.sp\n"
+
+    (** Print groff string for the given optional return information.*)
+    method man_of_return_opt b return_opt =
       match return_opt with
-        None -> ""
-      | Some s -> ".B "^Odoc_messages.returns^"\n"^(self#man_of_text s)^"\n.sp\n"
-
-    (** Return man code for the given list of custom tagged texts. *)
-    method man_of_custom l =
+        None -> ()
+      | Some s -> 
+	  bs b ".B ";
+	  bs b Odoc_messages.returns;
+	  bs b "\n";
+	  self#man_of_text b s;
+	  bs b "\n.sp\n"
+
+    (** Print man code for the given list of custom tagged texts. *)
+    method man_of_custom b l =
       let buf = Buffer.create 50 in
       List.iter
         (fun (tag, text) ->
@@ -110,31 +150,39 @@ class virtual info =
             Not_found ->
               Odoc_info.warning (Odoc_messages.tag_not_handled tag)
         )
-        l;
-      Buffer.contents buf
+        l
 
-    (** Return the groff string to display an optional info structure. *)
-    method man_of_info info_opt =
+    (** Print the groff string to display an optional info structure. *)
+    method man_of_info b info_opt =
         match info_opt with
-        None ->
-          ""
+        None -> ()
       | Some info ->
           let module M = Odoc_info in
-          (match info.M.i_deprecated with
-            None -> ""
-          | Some d -> ".B \""^Odoc_messages.deprecated^"\"\n"^(self#man_of_text d)^"\n.sp\n")^
-          (match info.M.i_desc with
-            None -> "" 
-          | Some d when d = [Odoc_info.Raw ""] -> ""
-          | Some d -> (self#man_of_text d)^"\n.sp\n"
-          )^
-          (self#man_of_author_list info.M.i_authors)^
-          (self#man_of_version_opt info.M.i_version)^
-          (self#man_of_since_opt info.M.i_since)^
-          (self#man_of_raised_exceptions info.M.i_raised_exceptions)^
-          (self#man_of_return_opt info.M.i_return_value)^
-          (self#man_of_sees info.M.i_sees)^
-          (self#man_of_custom info.M.i_custom)
+          (
+	   match info.M.i_deprecated with
+             None -> ()
+           | Some d -> 
+	       bs b ".B \"";
+	       bs b Odoc_messages.deprecated;
+	       bs b "\"\n";
+	       self#man_of_text b d;
+	       bs b "\n.sp\n"
+	  );
+          (
+	   match info.M.i_desc with
+             None -> ()
+           | Some d when d = [Odoc_info.Raw ""] -> ()
+           | Some d -> 
+	       self#man_of_text b d;
+	       bs b "\n.sp\n"
+          );
+          self#man_of_author_list b info.M.i_authors;
+          self#man_of_version_opt b info.M.i_version;
+          self#man_of_since_opt b info.M.i_since;
+          self#man_of_raised_exceptions b info.M.i_raised_exceptions;
+          self#man_of_return_opt b info.M.i_return_value;
+          self#man_of_sees b info.M.i_sees;
+          self#man_of_custom b info.M.i_custom
   end
 
 (** This class is used to create objects which can generate a simple html documentation. *)
@@ -156,71 +204,78 @@ class man =
       let f = Filename.concat !Args.target_dir file in
       open_out f
       
-    (** Return the groff string for a text, without correction of blanks. *)
-    method private man_of_text2 t = String.concat "" (List.map self#man_of_text_element t)
-
-    (** Return the groff string for a text, with blanks corrected. *)
-    method man_of_text t =
-      let s = self#man_of_text2 t in
+    (** Print groff string for a text, without correction of blanks. *)
+    method private man_of_text2 b t = 
+      List.iter (self#man_of_text_element b) t
+
+    (** Print the groff string for a text, with blanks corrected. *)
+    method man_of_text b t =
+      let b2 = new_buf () in
+      self#man_of_text2 b2 t ;
+      let s = Buffer.contents b2 in
       let s2 = Str.global_replace (Str.regexp "\n[ ]*") "\n" s in
-      Str.global_replace (Str.regexp "\n\n") "\n" s2
+      bs b (Str.global_replace (Str.regexp "\n\n") "\n" s2)
 
     (** Return the given string without no newlines. *)
     method remove_newlines s =
       Str.global_replace (Str.regexp "[ ]*\n[ ]*") " " s
       
-    (** Return the groff string for a text element. *)
-    method man_of_text_element te =
+    (** Print the groff string for a text element. *)
+    method man_of_text_element b te =
       match te with
-      | Odoc_info.Raw s -> s
+      | Odoc_info.Raw s -> bs b s
       | Odoc_info.Code s -> 
-          let s2 = "\n.B "^(Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n" in
-          s2
+          bs b "\n.B ";
+	  bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n")
       | Odoc_info.CodePre s -> 
-          let s2 = "\n.B "^(Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n" in
-          s2
-      | Odoc_info.Verbatim s -> self#escape s
+          bs b "\n.B ";
+	  bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n")
+      | Odoc_info.Verbatim s -> 
+	  bs b (self#escape s)
       | Odoc_info.Bold t
       | Odoc_info.Italic t
       | Odoc_info.Emphasize t
       | Odoc_info.Center t
       | Odoc_info.Left t
-      | Odoc_info.Right t -> self#man_of_text2 t
+      | Odoc_info.Right t -> 
+	  self#man_of_text2 b t
       | Odoc_info.List tl ->
-          (String.concat ""
-             (List.map
-                (fun t -> ".TP\n \"\"\n"^(self#man_of_text2 t)^"\n")
-                tl
-             )
-          )^"\n"
+          List.iter
+            (fun t -> bs b ".TP\n \"\"\n"; self#man_of_text2 b t; bs b "\n")
+            tl;
+          bs b "\n"
       | Odoc_info.Enum tl ->
-          (String.concat ""
-             (List.map
-                (fun t -> ".TP\n \"\"\n"^(self#man_of_text2 t)^"\n")
-                tl
-             )
-          )^"\n"
+          List.iter
+            (fun t -> bs b ".TP\n \"\"\n"; self#man_of_text2 b t; bs b "\n")
+            tl;
+          bs b "\n"
       | Odoc_info.Newline ->
-          "\n.sp\n"
+          bs b "\n.sp\n"
       | Odoc_info.Block t ->
-          "\n.sp\n"^(self#man_of_text2 t)^"\n.sp\n"
+          bs b "\n.sp\n";
+	  self#man_of_text2 b t;
+	  bs b "\n.sp\n"
       | Odoc_info.Title (n, l_opt, t) ->
-          self#man_of_text2 [Odoc_info.Code (Odoc_info.string_of_text t)]
+          self#man_of_text2 b [Odoc_info.Code (Odoc_info.string_of_text t)]
       | Odoc_info.Latex _ ->
           (* don't care about LaTeX stuff in HTML. *)
-          ""
+          ()
       | Odoc_info.Link (s, t) ->
-          self#man_of_text2 t
+          self#man_of_text2 b t
       | Odoc_info.Ref (name, _) ->
-          self#man_of_text_element 
+          self#man_of_text_element b
             (Odoc_info.Code (Odoc_info.use_hidden_modules name))
       | Odoc_info.Superscript t ->
-          "^{"^(self#man_of_text2 t)
+          bs b "^{"; self#man_of_text2 b t
       | Odoc_info.Subscript t ->
-          "_{"^(self#man_of_text2 t)
+          bs b "_{"; self#man_of_text2 b t
+      |	Odoc_info.Module_list _ ->
+	  ()
+      |	Odoc_info.Index_list -> 
+	  ()
 
-    (** Groff string to display code. *)
-    method man_of_code s = self#man_of_text [ Code s ]
+    (** Print groff string to display code. *)
+    method man_of_code b s = self#man_of_text b [ Code s ]
 
     (** Take a string and return the string where fully qualified idents 
        have been replaced by idents relative to the given module name.*)
@@ -239,295 +294,357 @@ class man =
       in
       s2
 
-    (** Groff string to display a [Types.type_expr].*)
-    method man_of_type_expr m_name t =
+    (** Print groff string to display a [Types.type_expr].*)
+    method man_of_type_expr b m_name t =
       let s = String.concat "\n"
-          (Str.split (Str.regexp "\n") (Odoc_misc.string_of_type_expr t))
+          (Str.split (Str.regexp "\n") (Odoc_print.string_of_type_expr t))
       in
       let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
-      "\n.B "^(self#relative_idents m_name s2)^"\n"
+      bs b "\n.B ";
+      bs b (self#relative_idents m_name s2);
+      bs b "\n"
 
-    (** Groff string to display a [Types.class_type].*)
-    method man_of_class_type_expr m_name t =
+    (** Print groff string to display a [Types.class_type].*)
+    method man_of_class_type_expr b m_name t =
       let s = String.concat "\n"
-          (Str.split (Str.regexp "\n") (Odoc_misc.string_of_class_type t))
+          (Str.split (Str.regexp "\n") (Odoc_print.string_of_class_type t))
       in
       let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
-      "\n.B "^(self#relative_idents m_name s2)^"\n"
+      bs b "\n.B ";
+      bs b (self#relative_idents m_name s2);
+      bs b "\n"
 
-    (** Groff string to display a [Types.type_expr list].*)
-    method man_of_type_expr_list m_name sep l =
-      let s = Odoc_str.string_of_type_list sep l in
+    (** Print groff string to display a [Types.type_expr list].*)
+    method man_of_type_expr_list ?par b m_name sep l =
+      let s = Odoc_str.string_of_type_list ?par sep l in
       let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
-      "\n.B "^(self#relative_idents m_name s2)^"\n"
+      bs b "\n.B ";
+      bs b (self#relative_idents m_name s2);
+      bs b "\n"
 
-    (** Groff string to display the parameters of a type.*)
-    method man_of_type_expr_param_list m_name t =
+    (** Print groff string to display the parameters of a type.*)
+    method man_of_type_expr_param_list b m_name t =
       match t.ty_parameters with
-        [] -> ""
+        [] -> ()
       | l ->
 	  let s = Odoc_str.string_of_type_param_list t in
 	  let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
-	  "\n.B "^(self#relative_idents m_name s2)^"\n"
+	  bs b "\n.B ";
+	  bs b (self#relative_idents m_name s2);
+	  bs b "\n"
 
-    (** Groff string to display a [Types.module_type]. *)
-    method man_of_module_type m_name t =
+    (** Print groff string to display a [Types.module_type]. *)
+    method man_of_module_type b m_name t =
       let s = String.concat "\n"
-          (Str.split (Str.regexp "\n") (Odoc_misc.string_of_module_type t))
+          (Str.split (Str.regexp "\n") (Odoc_print.string_of_module_type t))
       in
       let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
-      "\n.B "^(self#relative_idents m_name s2)^"\n"
+      bs b "\n.B ";
+      bs b (self#relative_idents m_name s2);
+      bs b "\n"
 
-    (** Groff string code for a value. *)
-    method man_of_value v =
+    (** Print groff string code for a value. *)
+    method man_of_value b v =
       Odoc_info.reset_type_names () ;
-      "\n.I val "^(Name.simple v.val_name)^" \n: "^
-      (self#man_of_type_expr (Name.father v.val_name) v.val_type)^
-      ".sp\n"^
-      (self#man_of_info v.val_info)^
-      "\n.sp\n"
-
-    (** Groff string code for an exception. *)
-    method man_of_exception e =
+      bs b "\n.I val ";
+      bs b (Name.simple v.val_name);
+      bs b " \n: ";
+      self#man_of_type_expr b (Name.father v.val_name) v.val_type;
+      bs b ".sp\n";
+      self#man_of_info b v.val_info;
+      bs b "\n.sp\n"
+
+    (** Print groff string code for an exception. *)
+    method man_of_exception b e =
       Odoc_info.reset_type_names () ;
-      "\n.I exception "^(Name.simple e.ex_name)^" \n"^
-      (match e.ex_args with
-        [] -> ""
-      | _ -> 
-          ".B of "^
-          (self#man_of_type_expr_list (Name.father e.ex_name) " * " e.ex_args)
-      )^
-      (match e.ex_alias with
-        None -> ""
-      | Some ea -> " = "^
-          (
-           match ea.ea_ex with
-             None -> ea.ea_name
-           | Some e -> e.ex_name
-          )
-      )^
-      "\n.sp\n"^
-      (self#man_of_info e.ex_info)^
-      "\n.sp\n"
+      bs b "\n.I exception ";
+      bs b (Name.simple e.ex_name);
+      bs b " \n";
+      (
+       match e.ex_args with
+         [] -> ()
+       | _ -> 
+           bs b ".B of ";
+           self#man_of_type_expr_list 
+	     ~par: false
+	     b (Name.father e.ex_name) " * " e.ex_args
+      );
+      (
+       match e.ex_alias with
+         None -> ()
+       | Some ea -> 
+	   bs b " = ";
+           bs b 
+	     (
+              match ea.ea_ex with
+		None -> ea.ea_name
+              | Some e -> e.ex_name
+             )
+      );
+      bs b "\n.sp\n";
+      self#man_of_info b e.ex_info;
+      bs b "\n.sp\n"
 
-    (** Groff string for a type. *)
-    method man_of_type t =
+    (** Print groff string for a type. *)
+    method man_of_type b t =
       Odoc_info.reset_type_names () ;
       let father = Name.father t.ty_name in
-      ".I type "^
-      (self#man_of_type_expr_param_list father t)^
-      (match t.ty_parameters with [] -> "" | _ -> ".I ")^(Name.simple t.ty_name)^" \n"^
-      (match t.ty_manifest with None -> "" | Some typ -> "= "^(self#man_of_type_expr father typ))^
+      bs b ".I type ";
+      self#man_of_type_expr_param_list b father t;
+      (
+       match t.ty_parameters with 
+	 [] -> () 
+       | _ -> bs b ".I "
+      );
+      bs b (Name.simple t.ty_name);
+      bs b " \n";
+      (
+       match t.ty_manifest with 
+	 None -> () 
+       | Some typ -> 
+	   bs b "= ";
+	   self#man_of_type_expr b father typ
+      );
       (
        match t.ty_kind with
-        Type_abstract -> 
-          ""
+        Type_abstract -> ()       
       | Type_variant (l, priv) ->
-          "="^(if priv then " private" else "")^"\n "^
-          (String.concat ""
-             (List.map 
-                (fun constr ->
-                  "| "^constr.vc_name^
-                  (match constr.vc_args, constr.vc_text with
-                    [], None -> "\n " 
-                  | [], (Some t) -> "  (* "^(self#man_of_text t)^" *)\n "
-                  | l, None -> 
-                      "\n.B of "^(self#man_of_type_expr_list father " * " l)^" "
-                  | l, (Some t) ->
-                      "\n.B of "^(self#man_of_type_expr_list father " * " l)^
-                      ".I \"  \"\n"^
-                      "(* "^(self#man_of_text t)^" *)\n "
-                  )
-                )
-                l
-             )
-          )
+          bs b "=";
+	  if priv then bs b " private";
+	  bs b "\n ";
+          List.iter 
+            (fun constr ->
+              bs b ("| "^constr.vc_name);
+              (
+	       match constr.vc_args, constr.vc_text with
+                 [], None -> bs b "\n " 
+               | [], (Some t) -> 
+		   bs b "  (* ";
+		   self#man_of_text b t;
+		   bs b " *)\n "
+               | l, None -> 
+                   bs b "\n.B of ";
+		   self#man_of_type_expr_list ~par: false b father " * " l;
+		   bs b " "
+               | l, (Some t) ->
+                   bs b "\n.B of ";
+		   self#man_of_type_expr_list ~par: false b father " * " l;
+                   bs b ".I \"  \"\n";
+                   bs b "(* ";
+		   self#man_of_text b t;
+		   bs b " *)\n "
+              )
+	    )
+            l
       | Type_record (l, priv) ->
-          "= "^(if priv then "private " else "")^"{"^
-          (String.concat ""
-             (List.map 
-                (fun r ->
-                  (if r.rf_mutable then "\n\n.B mutable \n" else "\n ")^
-                  r.rf_name^" : "^(self#man_of_type_expr father r.rf_type)^";"^
-                  (match r.rf_text with
-                    None ->
-                      ""
-                  | Some t ->
-                      "  (* "^(self#man_of_text t)^" *) "
-                  )^""
-                )
-                l
-             )
-          )^
-          "\n }\n"
-      )^
-      "\n.sp\n"^(self#man_of_info t.ty_info)^
-      "\n.sp\n"
-
-    (** Groff string for a class attribute. *)
-    method man_of_attribute a =
-      ".I val "^
-      (if a.att_mutable then Odoc_messages.mutab^" " else "")^
-      (Name.simple a.att_value.val_name)^" : "^
-      (self#man_of_type_expr (Name.father a.att_value.val_name) a.att_value.val_type)^
-      "\n.sp\n"^(self#man_of_info a.att_value.val_info)^
-      "\n.sp\n"
-
-    (** Groff string for a class method. *)
-    method man_of_method m =
-      ".I method "^
-      (if m.met_private then "private " else "")^
-      (if m.met_virtual then "virtual " else "")^
-      (Name.simple m.met_value.val_name)^" : "^
-      (self#man_of_type_expr (Name.father m.met_value.val_name) m.met_value.val_type)^
-      "\n.sp\n"^(self#man_of_info m.met_value.val_info)^
-      "\n.sp\n"
+          bs b "= ";
+	  if priv then bs b "private ";
+	  bs b "{";
+          List.iter 
+            (fun r ->
+              bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n ");
+              bs b (r.rf_name^" : ");
+	      self#man_of_type_expr b father r.rf_type;
+	      bs b ";";
+              (
+	       match r.rf_text with
+                 None -> ()
+               | Some t ->
+                   bs b "  (* ";
+		   self#man_of_text b t;
+		   bs b " *) "
+              );
+            )
+            l;
+          bs b "\n }\n"
+      );
+      bs b "\n.sp\n";
+      self#man_of_info b t.ty_info;
+      bs b "\n.sp\n"
+
+    (** Print groff string for a class attribute. *)
+    method man_of_attribute b a =
+      bs b ".I val ";
+      if a.att_mutable then bs b (Odoc_messages.mutab^" ");
+      bs b ((Name.simple a.att_value.val_name)^" : ");
+      self#man_of_type_expr b (Name.father a.att_value.val_name) a.att_value.val_type;
+      bs b "\n.sp\n";
+      self#man_of_info b a.att_value.val_info;
+      bs b "\n.sp\n"
+
+    (** Print groff string for a class method. *)
+    method man_of_method b m =
+      bs b ".I method ";
+      if m.met_private then bs b "private ";
+      if m.met_virtual then bs b "virtual ";
+      bs b ((Name.simple m.met_value.val_name)^" : ");
+      self#man_of_type_expr b 
+	(Name.father m.met_value.val_name) m.met_value.val_type;
+      bs b "\n.sp\n";
+      self#man_of_info b m.met_value.val_info;
+      bs b "\n.sp\n"
 
     (** Groff for a list of parameters. *)
-    method man_of_parameter_list m_name l =
+    method man_of_parameter_list b m_name l =
       match l with
-        [] ->
-          ""
+        [] -> ()
       | _ ->
-          "\n.B "^Odoc_messages.parameters^": \n"^
-          (String.concat ""
-             (List.map
-                (fun p ->
-                  ".TP\n"^
-                  "\""^(Parameter.complete_name p)^"\"\n"^
-                  (self#man_of_type_expr m_name (Parameter.typ p))^"\n"^
-                  (self#man_of_parameter_description p)^"\n"
-                )
-                l
-             )
-          )^"\n"
+          bs b "\n.B ";
+	  bs b Odoc_messages.parameters;
+	  bs b ": \n";
+	  List.iter
+            (fun p ->
+              bs b ".TP\n";
+              bs b "\"";
+	      bs b (Parameter.complete_name p);
+	      bs b "\"\n";
+              self#man_of_type_expr b m_name (Parameter.typ p);
+	      bs b "\n";
+              self#man_of_parameter_description b p;
+	      bs b "\n"
+            )
+            l;
+          bs b "\n"
 
     (** Groff for the description of a function parameter. *)
-    method man_of_parameter_description p =
+    method man_of_parameter_description b p =
       match Parameter.names p with
-        [] ->
-          ""
+        [] -> ()
       | name :: [] ->
           (
            (* Only one name, no need for label for the description. *)
            match Parameter.desc_by_name p name with
-             None -> ""
-           | Some t -> "\n "^(self#man_of_text t)
+             None -> ()
+           | Some t -> bs b "\n "; self#man_of_text b t
           )
       | l ->
           (*  A list of names, we display those with a description. *)
-          String.concat ""
-            (List.map
-               (fun n ->
-                 match Parameter.desc_by_name p n with
-                   None -> ""
-                 | Some t -> (self#man_of_code (n^" : "))^(self#man_of_text t)
-               )
-               l
+	  List.iter
+            (fun n ->
+              match Parameter.desc_by_name p n with
+                None -> ()
+              | Some t -> 
+		  self#man_of_code b (n^" : ");
+		  self#man_of_text b t
             )
+            l
 
-    (** Groff string for a list of module parameters. *)
-    method man_of_module_parameter_list m_name l =
+    (** Print groff string for a list of module parameters. *)
+    method man_of_module_parameter_list b m_name l =
       match l with
-        [] ->
-          ""
+        [] -> ()
       | _ ->
-          ".B \""^Odoc_messages.parameters^":\"\n"^
-          (String.concat ""
-             (List.map
-                (fun (p, desc_opt) ->
-                  ".TP\n"^
-                  "\""^p.mp_name^"\"\n"^
-                  (self#man_of_module_type m_name p.mp_type)^"\n"^
-                  (match desc_opt with
-                    None -> ""
-                  | Some t -> self#man_of_text t)^
-                  "\n"
-                )
-                l
-             )
-          )^"\n\n"
+          bs b ".B \"";
+	  bs b Odoc_messages.parameters;
+	  bs b ":\"\n";
+          List.iter
+            (fun (p, desc_opt) ->
+              bs b ".TP\n";
+              bs b ("\""^p.mp_name^"\"\n");
+              self#man_of_module_type b m_name p.mp_type;
+	      bs b "\n";
+              (
+	       match desc_opt with
+                 None -> ()
+               | Some t -> self#man_of_text b t
+	      );
+              bs b "\n"
+            )
+            l;
+          bs b "\n\n"
 
-    (** Groff string for a class. *)
-    method man_of_class c =
-      let buf = Buffer.create 32 in
-      let p = Printf.bprintf in
+    (** Print groff string for a class. *)
+    method man_of_class b c =
       Odoc_info.reset_type_names () ;
       let father = Name.father c.cl_name in
-      p buf ".I class %s"
-        (if c.cl_virtual then "virtual " else "");
+      bs b  ".I class ";
+      if c.cl_virtual then bs b "virtual ";
       (
        match c.cl_type_parameters with
          [] -> ()
-       | l -> p buf "[%s] " (Odoc_str.string_of_type_list ", " l)
+       | l -> 
+	   bs b (Odoc_str.string_of_class_type_param_list l);
+	   bs b " "
       );
-      p buf "%s : %s" 
-        (Name.simple c.cl_name)
-        (self#man_of_class_type_expr (Name.father c.cl_name) c.cl_type);
-      p buf "\n.sp\n%s\n.sp\n" (self#man_of_info c.cl_info);
-      Buffer.contents buf
-
-    (** Groff string for a class type. *)
-    method man_of_class_type ct =
-      let buf = Buffer.create 32 in
-      let p = Printf.bprintf in
+      bs b (Name.simple c.cl_name);
+      bs b " : " ;
+      self#man_of_class_type_expr b (Name.father c.cl_name) c.cl_type;
+      bs b "\n.sp\n";
+      self#man_of_info b c.cl_info;
+      bs b "\n.sp\n"
+
+    (** Print groff string for a class type. *)
+    method man_of_class_type b ct =
       Odoc_info.reset_type_names () ;
-      p buf ".I class type %s"
-        (if ct.clt_virtual then "virtual " else "");
+      bs b ".I class type ";
+      if ct.clt_virtual then bs b "virtual " ;
       (
        match ct.clt_type_parameters with
         [] -> ()
-      | l -> p buf "[%s] " (Odoc_str.string_of_type_list ", " l)
+      | l -> 
+	  bs b (Odoc_str.string_of_class_type_param_list l);
+	  bs b " "
       );
-      p buf "%s = %s" 
-        (Name.simple ct.clt_name)
-        (self#man_of_class_type_expr (Name.father ct.clt_name) ct.clt_type);
-      p buf "\n.sp\n%s\n.sp\n" (self#man_of_info ct.clt_info);
-      Buffer.contents buf
-
-    (** Groff string for a module. *)
-    method man_of_module m =
-      ".I module "^(Name.simple m.m_name)^
-      " : "^(self#man_of_module_type (Name.father m.m_name) m.m_type)^
-      "\n.sp\n"^(self#man_of_info m.m_info)^"\n.sp\n"
-
-    (** Groff string for a module type. *)
-    method man_of_modtype mt =
-      ".I module type "^(Name.simple mt.mt_name)^
-      " = "^
+      bs b (Name.simple ct.clt_name);
+      bs b  " = " ;
+      self#man_of_class_type_expr b (Name.father ct.clt_name) ct.clt_type;
+      bs b  "\n.sp\n"; 
+      self#man_of_info b ct.clt_info;
+      bs b "\n.sp\n"
+
+    (** Print groff string for a module. *)
+    method man_of_module b m =
+      bs b ".I module ";
+      bs b (Name.simple m.m_name);
+      bs b " : ";
+      self#man_of_module_type b (Name.father m.m_name) m.m_type;
+      bs b "\n.sp\n";
+      self#man_of_info b m.m_info;
+      bs b "\n.sp\n"
+
+    (** Print groff string for a module type. *)
+    method man_of_modtype b mt =
+      bs b ".I module type ";
+      bs b (Name.simple mt.mt_name);
+      bs b " = ";
       (match mt.mt_type with 
-        None -> ""
-      | Some t -> self#man_of_module_type (Name.father mt.mt_name) t
-      )^
-      "\n.sp\n"^(self#man_of_info mt.mt_info)^"\n.sp\n"
-
-    (** Groff string for a module comment.*)
-    method man_of_module_comment text =
-      "\n.pp\n"^
-      (self#man_of_text [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")])^
-      "\n.pp\n"
-
-    (** Groff string for a class comment.*)
-    method man_of_class_comment text =
-      "\n.pp\n"^
-      (self#man_of_text [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")])^
-      "\n.pp\n"
-
-    (** Groff string for an included module. *)
-    method man_of_included_module m_name im =
-      ".I include "^
+        None -> ()
+      | Some t -> 
+	  self#man_of_module_type b (Name.father mt.mt_name) t
+      );
+      bs b "\n.sp\n";
+      self#man_of_info b mt.mt_info;
+      bs b "\n.sp\n"
+
+    (** Print groff string for a module comment.*)
+    method man_of_module_comment b text =
+      bs b "\n.pp\n";
+      self#man_of_text b [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")];
+      bs b "\n.pp\n"
+
+    (** Print groff string for a class comment.*)
+    method man_of_class_comment b text =
+      bs b "\n.pp\n";
+      self#man_of_text b [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")];
+      bs b "\n.pp\n"
+
+    (** Print groff string for an included module. *)
+    method man_of_included_module b m_name im =
+      bs b ".I include ";
       (
        match im.im_module with
-         None -> im.im_name
+         None -> bs b im.im_name
        | Some mmt ->
            let name = 
              match mmt with
                Mod m -> m.m_name
              | Modtype mt -> mt.mt_name
            in
-           self#relative_idents m_name name
-      )^
-      "\n.sp\n"
+           bs b (self#relative_idents m_name name)
+      );
+      bs b "\n.sp\n";
+      self#man_of_info b im.im_info;
+      bs b "\n.sp\n"
 
     (** Generate the man page for the given class.*)
     method generate_for_class cl =
@@ -536,12 +653,13 @@ class man =
       let file = self#file_name cl.cl_name in
       try
         let chanout = self#open_out file in
-        output_string chanout
-          (".TH \""^Odoc_messages.clas^"\" "^
-           cl.cl_name^" "^
-           "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ 
-           "OCamldoc "^
-           "\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+	let b = new_buf () in
+	bs b ".TH \"";
+	bs b Odoc_messages.clas; 
+	bs b ("\" "^cl.cl_name^" ");
+        bs b ("\""^(Odoc_misc.string_of_date ~hour: false date)^"\" ");
+        bs b "OCamldoc ";
+        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
 
 	let abstract = 
 	  match cl.cl_info with
@@ -551,22 +669,18 @@ class man =
 	      self#remove_newlines s
 	in
 
-        output_string chanout
-          (
-	   ".SH NAME\n"^
-	   cl.cl_name^" \\- "^abstract^"\n"^
-           ".SH "^Odoc_messages.clas^"\n"^
-           Odoc_messages.clas^"   "^cl.cl_name^"\n"^
-           ".SH "^Odoc_messages.documentation^"\n"^
-           ".sp\n"
-          );
-        output_string chanout (self#man_of_class cl);
+	bs b ".SH NAME\n";
+	bs b (cl.cl_name^" \\- "^abstract^"\n");
+        bs b (".SH "^Odoc_messages.clas^"\n");
+        bs b (Odoc_messages.clas^"   "^cl.cl_name^"\n");
+        bs b (".SH "^Odoc_messages.documentation^"\n");
+        bs b ".sp\n";
+        self#man_of_class b cl;
 
         (* parameters *)
-        output_string chanout 
-          (self#man_of_parameter_list "" cl.cl_parameters);
+        self#man_of_parameter_list b "" cl.cl_parameters;
         (* a large blank *)
-        output_string chanout "\n.sp\n.sp\n";
+        bs b  "\n.sp\n.sp\n";
 
 (*
         (* class inheritance *)
@@ -577,14 +691,15 @@ class man =
           (fun element ->
             match element with
               Class_attribute a ->
-                output_string chanout (self#man_of_attribute a)
+                self#man_of_attribute b a
             | Class_method m ->
-                output_string chanout (self#man_of_method m)
+                self#man_of_method b m
             | Class_comment t ->
-                output_string chanout (self#man_of_class_comment t)
+                self#man_of_class_comment b t
           )
           (Class.class_elements cl);
 
+	Buffer.output_buffer chanout b;
         close_out chanout
       with
         Sys_error s ->
@@ -598,12 +713,12 @@ class man =
       let file = self#file_name ct.clt_name in
       try
         let chanout = self#open_out file in
-        output_string chanout
-          (".TH \""^Odoc_messages.class_type^"\" "^
-           ct.clt_name^" "^
-           "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ 
-           "OCamldoc "^
-           "\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+	let b = new_buf () in
+	bs b (".TH \""^Odoc_messages.class_type^"\" ");
+        bs b (ct.clt_name^" ");
+        bs b ("\""^(Odoc_misc.string_of_date ~hour: false date)^"\" ");
+        bs b "OCamldoc ";
+        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
 
 	let abstract = 
 	  match ct.clt_info with
@@ -613,19 +728,17 @@ class man =
 	      self#remove_newlines s
 	in
 
-        output_string chanout
-          (
-	   ".SH NAME\n"^
-	   ct.clt_name^" \\- "^abstract^"\n"^
-           ".SH "^Odoc_messages.class_type^"\n"^
-           Odoc_messages.class_type^"   "^ct.clt_name^"\n"^
-           ".SH "^Odoc_messages.documentation^"\n"^
-           ".sp\n"
-          );
-        output_string chanout (self#man_of_class_type ct);
+        bs b ".SH NAME\n";
+	bs b (ct.clt_name^" \\- "^abstract^"\n");
+        bs b (".SH "^Odoc_messages.class_type^"\n");
+        bs b (Odoc_messages.class_type^"   "^ct.clt_name^"\n");
+        bs b (".SH "^Odoc_messages.documentation^"\n");
+        bs b ".sp\n";
+        
+	self#man_of_class_type b ct;
 
         (* a large blank *)
-        output_string chanout "\n.sp\n.sp\n";
+        bs b "\n.sp\n.sp\n";
 (*
         (* class inheritance *)
         self#generate_class_inheritance_info chanout cl;
@@ -635,14 +748,15 @@ class man =
           (fun element ->
             match element with
               Class_attribute a ->
-                output_string chanout (self#man_of_attribute a)
+                self#man_of_attribute b a
             | Class_method m ->
-                output_string chanout (self#man_of_method m)
+                self#man_of_method b m
             | Class_comment t ->
-                output_string chanout (self#man_of_class_comment t)
+                self#man_of_class_comment b t
           )
           (Class.class_type_elements ct);
 
+	Buffer.output_buffer chanout b;
         close_out chanout
       with
         Sys_error s ->
@@ -656,12 +770,12 @@ class man =
       let file = self#file_name mt.mt_name in
       try
         let chanout = self#open_out file in
-        output_string chanout
-          (".TH \""^Odoc_messages.module_type^"\" "^
-           mt.mt_name^" "^
-           "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ 
-           "OCamldoc "^
-           "\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+	let b = new_buf () in
+	bs b (".TH \""^Odoc_messages.module_type^"\" ");
+        bs b (mt.mt_name^" ");
+        bs b ("\""^(Odoc_misc.string_of_date ~hour: false date)^"\" ");
+        bs b "OCamldoc ";
+        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
 
 	let abstract = 
 	  match mt.mt_info with
@@ -670,57 +784,56 @@ class man =
 	      let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in
 	      self#remove_newlines s
 	in
-        output_string chanout
-          (
-	   ".SH NAME\n"^
-	   mt.mt_name^" \\- "^abstract^"\n"^
-           ".SH "^Odoc_messages.module_type^"\n"^
-           Odoc_messages.module_type^"   "^mt.mt_name^"\n"^
-           ".SH "^Odoc_messages.documentation^"\n"^
-           ".sp\n"^
-           Odoc_messages.module_type^"\n"^
-           ".BI \""^(Name.simple mt.mt_name)^"\"\n"^
-           " = "^
-           (match mt.mt_type with
-             None -> ""
-           | Some t -> self#man_of_module_type (Name.father mt.mt_name) t
-           )^
-           "\n.sp\n"^
-           (self#man_of_info mt.mt_info)^"\n"^
-           ".sp\n"
-          );
+	bs b ".SH NAME\n";
+	bs b (mt.mt_name^" \\- "^abstract^"\n");
+        bs b (".SH "^Odoc_messages.module_type^"\n");
+        bs b (Odoc_messages.module_type^"   "^mt.mt_name^"\n");
+        bs b (".SH "^Odoc_messages.documentation^"\n");
+        bs b ".sp\n";
+        bs b (Odoc_messages.module_type^"\n");
+        bs b (".BI \""^(Name.simple mt.mt_name)^"\"\n");
+        bs b " = ";
+        (
+	 match mt.mt_type with
+           None -> ()
+         | Some t -> 
+	     self#man_of_module_type b (Name.father mt.mt_name) t
+        );
+        bs b "\n.sp\n";
+        self#man_of_info b mt.mt_info;
+	bs b "\n.sp\n";
 
         (* parameters for functors *)
-        output_string chanout 
-          (self#man_of_module_parameter_list "" (Module.module_type_parameters mt));
+        self#man_of_module_parameter_list b "" (Module.module_type_parameters mt);
         (* a large blank *)
-        output_string chanout "\n.sp\n.sp\n";
+        bs b "\n.sp\n.sp\n";
 
         (* module elements *)
         List.iter 
           (fun ele ->
             match ele with
               Element_module m ->
-                output_string chanout (self#man_of_module m)
+                self#man_of_module b m
             | Element_module_type mt ->
-                output_string chanout (self#man_of_modtype mt)
+                self#man_of_modtype b mt
             | Element_included_module im ->
-                output_string chanout (self#man_of_included_module mt.mt_name im)
+                self#man_of_included_module b mt.mt_name im
             | Element_class c ->
-                output_string chanout (self#man_of_class c)
+                self#man_of_class b c
             | Element_class_type ct ->
-                output_string chanout (self#man_of_class_type ct)
+                self#man_of_class_type b ct
             | Element_value v ->
-                output_string chanout (self#man_of_value v)
+                self#man_of_value b v
             | Element_exception e ->
-                output_string chanout (self#man_of_exception e)
+                self#man_of_exception b e
             | Element_type t ->
-                output_string chanout (self#man_of_type t)
+                self#man_of_type b t
             | Element_module_comment text ->
-                output_string chanout (self#man_of_module_comment text)
+                self#man_of_module_comment b text
           )
           (Module.module_type_elements mt);
 
+	Buffer.output_buffer chanout b;
         close_out chanout
 
       with
@@ -735,12 +848,14 @@ class man =
       let file = self#file_name m.m_name in
       try
         let chanout = self#open_out file in
-        output_string chanout
-          (".TH \""^Odoc_messages.modul^"\" "^
-           m.m_name^" "^
-           "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ 
-           "OCamldoc "^
-           "\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+	let b = new_buf () in
+        bs b ".TH \"";
+	bs b Odoc_messages.modul;
+	bs b "\" ";
+        bs b (m.m_name^" ");
+        bs b ("\""^(Odoc_misc.string_of_date ~hour: false date)^"\" ");
+        bs b "OCamldoc ";
+        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
 
 	let abstract = 
 	  match m.m_info with
@@ -750,53 +865,51 @@ class man =
 	      self#remove_newlines s
 	in
 
-        output_string chanout
-          (
-	   ".SH NAME\n"^
-	   m.m_name^" \\- "^abstract^"\n"^
-           ".SH "^Odoc_messages.modul^"\n"^
-           Odoc_messages.modul^"   "^m.m_name^"\n"^
-           ".SH "^Odoc_messages.documentation^"\n"^
-           ".sp\n"^
-           Odoc_messages.modul^"\n"^
-           ".BI \""^(Name.simple m.m_name)^"\"\n"^
-           " : "^(self#man_of_module_type (Name.father m.m_name) m.m_type)^
-           "\n.sp\n"^
-           (self#man_of_info m.m_info)^"\n"^
-           ".sp\n"
-          );
+	bs b ".SH NAME\n";
+	bs b (m.m_name^" \\- "^abstract^"\n");
+        bs b (".SH "^Odoc_messages.modul^"\n");
+        bs b (Odoc_messages.modul^"   "^m.m_name^"\n");
+        bs b (".SH "^Odoc_messages.documentation^"\n");
+        bs b ".sp\n";
+        bs b (Odoc_messages.modul^"\n");
+        bs b (".BI \""^(Name.simple m.m_name)^"\"\n");
+        bs b " : ";
+	self#man_of_module_type b (Name.father m.m_name) m.m_type;
+        bs b "\n.sp\n";
+        self#man_of_info b m.m_info;
+	bs b "\n.sp\n";
 
         (* parameters for functors *)
-        output_string chanout 
-          (self#man_of_module_parameter_list "" (Module.module_parameters m));
+        self#man_of_module_parameter_list b "" (Module.module_parameters m);
         (* a large blank *)
-        output_string chanout "\n.sp\n.sp\n";
+        bs b "\n.sp\n.sp\n";
 
         (* module elements *)
         List.iter 
           (fun ele ->
             match ele with
               Element_module m ->
-                output_string chanout (self#man_of_module m)
+                self#man_of_module b m
             | Element_module_type mt ->
-                output_string chanout (self#man_of_modtype mt)
+                self#man_of_modtype b mt
             | Element_included_module im ->
-                output_string chanout (self#man_of_included_module m.m_name im)
+                self#man_of_included_module b m.m_name im
             | Element_class c ->
-                output_string chanout (self#man_of_class c)
+                self#man_of_class b c
             | Element_class_type ct ->
-                output_string chanout (self#man_of_class_type ct)
+                self#man_of_class_type b ct
             | Element_value v ->
-                output_string chanout (self#man_of_value v)
+                self#man_of_value b v
             | Element_exception e ->
-                output_string chanout (self#man_of_exception e)
+                self#man_of_exception b e
             | Element_type t ->
-                output_string chanout (self#man_of_type t)
+                self#man_of_type b t
             | Element_module_comment text ->
-                output_string chanout (self#man_of_module_comment text)
+                self#man_of_module_comment b text
           )
           (Module.module_elements m);
 
+	Buffer.output_buffer chanout b;
         close_out chanout
 
       with
@@ -864,52 +977,44 @@ class man =
       let file = self#file_name name in
       try
         let chanout = self#open_out file in
-        output_string chanout
-          (
-	   ".TH \""^name^"\" "^
-           "man "^
-           "\""^(Odoc_misc.string_of_date ~hour: false date)^"\" "^ 
-           "OCamldoc "^
-           "\""^(match !Args.title with Some t -> t | None -> "")^"\"\n"^
-	   ".SH NAME\n"^
-	   name^" \\- all "^name^" elements\n\n"
-	  );
+	let b = new_buf () in
+        bs b (".TH \""^name^"\" ");
+        bs b "man ";
+        bs b ("\""^(Odoc_misc.string_of_date ~hour: false date)^"\" ");
+        bs b "OCamldoc ";
+        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+	bs b ".SH NAME\n";
+	bs b (name^" \\- all "^name^" elements\n\n");
 
         let f ele =
           match ele with
             Res_value v ->
-              output_string chanout
-                ("\n.SH "^Odoc_messages.modul^" "^(Name.father v.val_name)^"\n"^
-                 (self#man_of_value v))
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father v.val_name)^"\n");
+              self#man_of_value b v
           | Res_type t ->
-              output_string chanout
-                ("\n.SH "^Odoc_messages.modul^" "^(Name.father t.ty_name)^"\n"^
-                 (self#man_of_type t))
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father t.ty_name)^"\n");
+              self#man_of_type b t
           | Res_exception e ->
-              output_string chanout
-                ("\n.SH "^Odoc_messages.modul^" "^(Name.father e.ex_name)^"\n"^
-                 (self#man_of_exception e))
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father e.ex_name)^"\n");
+              self#man_of_exception b e
           | Res_attribute a ->
-              output_string chanout
-                ("\n.SH "^Odoc_messages.clas^" "^(Name.father a.att_value.val_name)^"\n"^
-                 (self#man_of_attribute a))
+              bs b ("\n.SH "^Odoc_messages.clas^" "^(Name.father a.att_value.val_name)^"\n");
+              self#man_of_attribute b a
           | Res_method m ->
-              output_string chanout
-                ("\n.SH "^Odoc_messages.clas^" "^(Name.father m.met_value.val_name)^"\n"^
-                 (self#man_of_method m))
+              bs b ("\n.SH "^Odoc_messages.clas^" "^(Name.father m.met_value.val_name)^"\n");
+              self#man_of_method b m
           | Res_class c ->
-              output_string chanout
-                ("\n.SH "^Odoc_messages.modul^" "^(Name.father c.cl_name)^"\n"^
-                 (self#man_of_class c))
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father c.cl_name)^"\n");
+              self#man_of_class b c
           | Res_class_type ct ->
-              output_string chanout
-                ("\n.SH "^Odoc_messages.modul^" "^(Name.father ct.clt_name)^"\n"^
-                 (self#man_of_class_type ct))
+              bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father ct.clt_name)^"\n");
+              self#man_of_class_type b ct
           | _ ->
               (* normalement on ne peut pas avoir de module ici. *)
               ()
         in
         List.iter f l;
+	Buffer.output_buffer chanout b;
         close_out chanout
       with
         Sys_error s ->
diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml
index a04e4ba8..6d5e3ed3 100644
--- a/ocamldoc/odoc_merge.ml
+++ b/ocamldoc/odoc_merge.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_merge.ml,v 1.10 2004/01/18 14:26:14 guesdon Exp $ *)
 
 (** Merge of information from [.ml] and [.mli] for a module.*)
 
@@ -683,6 +684,28 @@ and merge_modules merge_options mli ml =
   mli.m_loc <- { mli.m_loc with loc_impl = ml.m_loc.loc_impl } ;
   (* More dependencies in the .ml file. *)
   mli.m_top_deps <- ml.m_top_deps ;
+  
+  let code = 
+    if !Odoc_args.keep_code then
+      match mli.m_code, ml.m_code with
+	Some s, _ -> Some s
+      |	_, Some s -> Some s
+      |	_ -> None
+    else
+      None
+  in
+  let code_intf = 
+    if !Odoc_args.keep_code then
+      match mli.m_code_intf, ml.m_code_intf with
+	Some s, _ -> Some s
+      |	_, Some s -> Some s
+      |	_ -> None
+    else
+      None
+  in
+  mli.m_code <- code;
+  mli.m_code_intf <- code_intf;
+
   (* merge exceptions *)
   List.iter
     (fun ex ->
@@ -937,3 +960,4 @@ let merge merge_options modules_list =
   in
   iter modules_list
   
+(* eof $Id: odoc_merge.ml,v 1.10 2004/01/18 14:26:14 guesdon Exp $ *)
diff --git a/ocamldoc/odoc_merge.mli b/ocamldoc/odoc_merge.mli
index 3dadeecc..904d62c7 100644
--- a/ocamldoc/odoc_merge.mli
+++ b/ocamldoc/odoc_merge.mli
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_merge.mli,v 1.3 2003/11/24 10:41:05 starynke Exp $ *)
 
 (** Merge of information from [.ml] and [.mli] for a module.*)
 
diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml
index 80b99f67..1a7c337b 100644
--- a/ocamldoc/odoc_messages.ml
+++ b/ocamldoc/odoc_messages.ml
@@ -9,115 +9,153 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_messages.ml,v 1.24.4.2 2004/07/09 14:32:42 guesdon Exp $ *)
 
 (** The messages of the application. *)
 
 let ok = "Ok"
 let software = "OCamldoc"
-let version = Config.version
-let magic = version^""
-let message_version = software^" "^version
+let config_version = Config.version
+let magic = config_version^""
+let message_version = software^" "^config_version
 
 (** Messages for command line *)
 
 let usage = "Usage : "^(Sys.argv.(0))^" [options] \n"
 let options_are = "Options are :"
-let option_version = " Print version and exit"
+let option_version = "\tPrint version and exit"
+let bytecode_only = "(bytecode version only)"
 let latex_only = "(LaTeX only)"
 let texi_only = "(TeXinfo only)"
 let latex_texi_only = "(LaTeX and TeXinfo only)"
 let html_only = "(HTML only)"
+let html_latex_only = "(HTML and LaTeX only)"
+let html_latex_texi_only = "(HTML, LaTeX and TeXinfo only)"
 let man_only = "(man only)"
-let verbose_mode = " verbose mode"
-let include_dirs = "  Add  to the list of include directories"
-let rectypes = " Allow arbitrary recursive types"
-let preprocess = "  Pipe sources through preprocessor "
-let load_file = "  Load file defining a new documentation generator (bytecode version only)"
-let nolabels = " Ignore non-optional labels in types"
-let werr = "Treat ocamldoc warnings as errors"
-let target_dir = "  Generate files in directory , rather than in current directory (for man and HTML generators)"
-let dump = "  Dump collected information into "
-let load = "  Load information from  ; may be used several times"
-let css_style = "  Use content of  as CSS style definition "^html_only
-let index_only = " Generate index files only "^html_only
-let colorize_code = "Colorize code even in documentation pages "^html_only
-let generate_html = " Generate HTML documentation"
-let generate_latex = " Generate LaTeX documentation"
-let generate_texinfo = " Generate TeXinfo documentation"
-let generate_man = " Generate man pages"
-let generate_dot = " Generate dot code of top modules dependencies"
+let verbose_mode = "\t\tverbose mode"
+let include_dirs = "\tAdd  to the list of include directories"
+let rectypes = "\tAllow arbitrary recursive types"
+let preprocess = "\tPipe sources through preprocessor "
+let display_custom_generators_dir = "\tDisplay custom generators standard directory and exit"
+let add_load_dir = "\tAdd the given directory to the search path for custom\n"^
+  "\t\tgenerators "^bytecode_only
+let load_file = "\n\t\tLoad file defining a new documentation generator\n\t\t"^bytecode_only
+let nolabels = "\tIgnore non-optional labels in types"
+let werr = "\tTreat ocamldoc warnings as errors"
+let target_dir = "\tGenerate files in directory , rather than in current\n"^
+  "\t\tdirectory (for man and HTML generators)"
+let dump = "\tDump collected information into "
+let load = "\tLoad information from  ; may be used several times"
+let css_style = "\n\t\tUse content of  as CSS style definition "^html_only
+let index_only = "\tGenerate index files only "^html_only
+let colorize_code = "\n\t\tColorize code even in documentation pages "^html_only
+let generate_html = "\tGenerate HTML documentation"
+let generate_latex = "\tGenerate LaTeX documentation"
+let generate_texinfo = "\tGenerate TeXinfo documentation"
+let generate_man = "\t\tGenerate man pages"
+let generate_dot = "\t\tGenerate dot code of top modules dependencies"
 
 let option_not_in_native_code op = "Option "^op^" not available in native code version."
 
 let default_out_file = "ocamldoc.out"
-let out_file = " Set the ouput file name, used by texi, latex and dot generators "^
-  "(default is "^default_out_file^")"
-
-let dot_include_all = " include all modules in the dot output,\n"^
-  "        not only the modules given on the command line"
-let dot_types = " generate dependency graph for types instead of modules"
-let default_dot_colors = [ "darkturquoise" ; "darkgoldenrod2" ; "cyan" ; "green" ; "magenta" ; "yellow" ;
-                           "burlywood1" ; "aquamarine" ; "floralwhite" ; "lightpink" ;
-                           "lightblue" ; "mediumturquoise" ; "salmon" ; "slategray3" ;
-                         ] 
-let dot_colors = "  use colors c1,c1,...,cn in the dot output\n"^
-  "        (default list is "^(String.concat "," default_dot_colors)^")"
-let dot_reduce = " perform a transitive reduction on the selected dependency graph before the dot output\n"
-
-let man_mini = " Generate man pages only for modules, module types,\n"^
-  "        classes and class types "^man_only
+let out_file = 
+  "\tSet the ouput file name, used by texi, latex and dot generators\n"^
+  "\t\t(default is "^default_out_file^")"
+
+let dot_include_all = 
+  "\n\t\tInclude all modules in the dot output, not only the\n"^
+  "\t\tmodules given on the command line"
+let dot_types = "\tGenerate dependency graph for types instead of modules"
+let default_dot_colors = 
+  [ [ "darkturquoise" ; "darkgoldenrod2" ; "cyan" ; "green" ; ] ;
+    [ "magenta" ; "yellow" ; "burlywood1" ; "aquamarine" ; "floralwhite" ; "lightpink" ] ;
+    [ "lightblue" ; "mediumturquoise" ; "salmon" ; "slategray3"] ;
+  ] 
+
+let dot_colors = 
+  "\n\t\tUse colors c1,c1,...,cn in the dot output\n"^
+  "\t\t(default list is "^
+  (String.concat ",\n\t\t" (List.map (String.concat ", ") default_dot_colors))^")"
+
+let dot_reduce = 
+  "\tPerform a transitive reduction on the selected dependency graph\n"^
+  "\t\tbefore the dot output"
+
+let man_mini = "\tGenerate man pages only for modules, module types, classes\n"^
+  "\t\tand class types "^man_only
 let default_man_suffix = "o"
-let man_suffix = "  use  for man page files "^
+let man_suffix = "\n\t\tUse  for man page files "^
   "(default is "^default_man_suffix^") "^man_only^"\n"
 
-let option_title = "  use <title> as title for the generated documentation"
-let with_parameter_list = " display the complete list of parameters for functions and methods "^html_only
-let hide_modules = " <M1,M2.M3,...> Hide the given complete module names in generated doc"
-let no_header = " Suppress header in generated documentation "^latex_texi_only
-let no_trailer = " Suppress trailer in generated documentation "^latex_texi_only
-let separate_files = " Generate one file per toplevel module "^latex_only
+let option_title = "<title>\tUse <title> as title for the generated documentation"
+let option_intro = 
+  "<file>\tUse content of <file> as ocamldoc text to use as introduction\n"^
+  "\t\t"^(html_latex_texi_only)
+let with_parameter_list = "\tDisplay the complete list of parameters for functions and\n"^
+  "\t\tmethods "^html_only
+let hide_modules = "<M1,M2.M3,...>\n\t\tHide the given complete module names in generated doc"
+let no_header = "\tSuppress header in generated documentation\n\t\t"^latex_texi_only
+let no_trailer = "\tSuppress trailer in generated documentation\n\t\t"^latex_texi_only
+let separate_files = "\tGenerate one file per toplevel module "^latex_only
 let latex_title ref_titles = 
-  "n,style  associate {n } to the given sectionning style\n"^
-  "              (e.g. 'section') in the latex output "^latex_only^"\n"^
-  "              Default sectionning is:\n"^
-  (String.concat "\n"
-     (List.map (fun (n,t) -> Printf.sprintf "                %d -> %s" n t) !ref_titles))
+  "n,style\n\t\tAssociate {n } to the given sectionning style\n"^
+  "\t\t(e.g. 'section') in the latex output "^latex_only^"\n"^
+  "\t\tDefault sectionning is:\n\t\t"^
+  (String.concat "\n\t\t"
+     (List.map (fun (n,t) -> Printf.sprintf " %d -> %s" n t) !ref_titles))
 
 let default_latex_value_prefix = "val:"
-let latex_value_prefix = "<string>  use <string> as prefix for the LaTeX labels of values. "^
-  "(default is \""^default_latex_value_prefix^"\")"
+let latex_value_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of values.\n"^
+  "\t\t(default is \""^default_latex_value_prefix^"\")"
+
 let default_latex_type_prefix = "type:"
-let latex_type_prefix = "<string>  use <string> as prefix for the LaTeX labels of types. "^
-  "(default is \""^default_latex_type_prefix^"\")"
+let latex_type_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of types.\n"^
+  "\t\t(default is \""^default_latex_type_prefix^"\")"
+
 let default_latex_exception_prefix = "exception:"
-let latex_exception_prefix = "<string>  use <string> as prefix for the LaTeX labels of exceptions. "^
-  "(default is \""^default_latex_exception_prefix^"\")"
+let latex_exception_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^
+  "\t\t(default is \""^default_latex_exception_prefix^"\")"
+
 let default_latex_module_prefix = "module:"
-let latex_module_prefix = "<string>  use <string> as prefix for the LaTeX labels of modules. "^
-  "(default is \""^default_latex_module_prefix^"\")"
+let latex_module_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of modules.\n"^
+  "\t\t(default is \""^default_latex_module_prefix^"\")"
+
 let default_latex_module_type_prefix = "moduletype:"
-let latex_module_type_prefix = "<string>  use <string> as prefix for the LaTeX labels of module types. "^
-  "(default is \""^default_latex_module_type_prefix^"\")"
+let latex_module_type_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of module types.\n"^
+  "\t\t(default is \""^default_latex_module_type_prefix^"\")"
+
 let default_latex_class_prefix = "class:"
-let latex_class_prefix = "<string>  use <string> as prefix for the LaTeX labels of classes. "^
-  "(default is \""^default_latex_class_prefix^"\")"
+let latex_class_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of classes.\n"^
+  "\t\t(default is \""^default_latex_class_prefix^"\")"
+
 let default_latex_class_type_prefix = "classtype:"
-let latex_class_type_prefix = "<string>  use <string> as prefix for the LaTeX labels of class types. "^
-  "(default is \""^default_latex_class_type_prefix^"\")"
+let latex_class_type_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of class types.\n"^
+  "\t\t(default is \""^default_latex_class_type_prefix^"\")"
+
 let default_latex_attribute_prefix = "val:"
-let latex_attribute_prefix = "<string>  use <string> as prefix for the LaTeX labels of attributes. "^
-  "(default is \""^default_latex_attribute_prefix^"\")"
+let latex_attribute_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of attributes.\n"^
+  "\t\t(default is \""^default_latex_attribute_prefix^"\")"
+
 let default_latex_method_prefix = "method:"
-let latex_method_prefix = "<string>  use <string> as prefix for the LaTeX labels of methods. "^
-  "(default is \""^default_latex_method_prefix^"\")"
-
-let no_toc = " Do not generate table of contents "^latex_only
-let sort_modules = " Sort the list of top modules before generating the documentation"
-let no_stop = " Do not stop at (**/**) comments"
-let no_custom_tags = " Do not allow custom @-tags"
-let remove_stars = " Remove beginning blanks of comment lines, until the first '*'"
-let keep_code = " Always keep code when available"
-let inverse_merge_ml_mli = "Inverse implementations and interfaces when merging"
+let latex_method_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of methods.\n"^
+  "\t\t(default is \""^default_latex_method_prefix^"\")"
+
+let no_toc = "\tDo not generate table of contents "^latex_only
+let sort_modules = "\tSort the list of top modules before generating the documentation"
+let no_stop = "\tDo not stop at (**/**) comments"
+let no_custom_tags = "\n\t\tDo not allow custom @-tags"
+let remove_stars = "\tRemove beginning blanks of comment lines, until the first '*'"
+let keep_code = "\tAlways keep code when available"
+let inverse_merge_ml_mli = "\n\t\tInverse implementations and interfaces when merging"
 let merge_description = ('d', "merge description")
 let merge_author = ('a', "merge @author")
 let merge_version = ('v', "merge @version")
@@ -130,19 +168,19 @@ let merge_return_value = ('r', "merge @return")
 let merge_custom = ('c', "merge custom @-tags")
 let merge_all = ('A', "merge all")
 
-let no_index = " Do not build index for Info files "^texi_only
-let esc_8bits = " Escape accentuated characters in Info files "^texi_only
+let no_index = "\tDo not build index for Info files "^texi_only
+let esc_8bits = "\tEscape accentuated characters in Info files "^texi_only
 let info_section = "Specify section of Info directory "^texi_only
-let info_entry = "Specify Info directory entry "^texi_only^"\n"
+let info_entry = "\tSpecify Info directory entry "^texi_only
 
-let options_can_be = "        <options> can be one or more of the following characters:"
+let options_can_be = "<options> can be one or more of the following characters:"
 let string_of_options_list l = 
-  List.fold_left (fun acc -> fun (c, m) -> acc^"\n        "^(String.make 1 c)^"  "^m)
+  List.fold_left (fun acc -> fun (c, m) -> acc^"\n\t\t"^(String.make 1 c)^"  "^m)
     ""
     l
 
 let merge_options = 
-  "<options>  specify merge options between .mli and .ml\n"^
+  "<options>\tspecify merge options between .mli and .ml\n\t\t"^
   options_can_be^
   (string_of_options_list
      [ merge_description ;
@@ -171,7 +209,7 @@ let bad_magic_number =
   "This dump was not created by this version of OCamldoc."
 
 let not_a_module_name s = s^" is not a valid module name"
-let load_file_error f e = "Error while loading file "^f^":\n"^e^"\n"
+let load_file_error f e = "Error while loading file "^f^":\n"^e
 let wrong_format s = "Wrong format for \""^s^"\""
 let errors_occured n = (string_of_int n)^" error(s) encountered"
 let parse_error = "Parse error"
@@ -182,6 +220,11 @@ let text_parse_error l c s =
   (List.nth lines l)^"\n"^
   (String.make c ' ')^"^"
 
+let file_not_found_in_paths paths name =
+  Printf.sprintf "No file %s found in the load paths: \n%s"
+    name
+    (String.concat "\n" paths)
+
 let tag_not_handled tag = "Tag @"^tag^" not handled by this generator"
 let bad_tree = "Incorrect tree structure."
 let not_a_valid_tag s = s^" is not a valid tag."
diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml
index d2c3c52e..a50b86d5 100644
--- a/ocamldoc/odoc_misc.ml
+++ b/ocamldoc/odoc_misc.ml
@@ -9,7 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-
+(* $Id: odoc_misc.ml,v 1.17 2004/05/23 10:41:50 guesdon Exp $ *)
 
 let input_file_as_string nom =
   let chanin = open_in_bin nom in
@@ -33,62 +33,34 @@ let input_file_as_string nom =
   close_in chanin;
   Buffer.contents buf
 
-let string_of_longident li = String.concat "." (Longident.flatten li)
-
-let string_of_type_expr t =
-  let b = Buffer.create 256 in
-  let fmt = Format.formatter_of_buffer b in
-  Printtyp.mark_loops t;
-  Printtyp.type_scheme_max ~b_reset_names: false fmt t;
-  Format.pp_print_flush fmt () ;
-  Buffer.contents b
-
-(** Return the given module type where methods and vals have been removed
-   from the signatures. Used when we don't want to print a too long module type.*)
-let simpl_module_type t =
-  let rec iter t =
-    match t with
-      Types.Tmty_ident p -> t
-    | Types.Tmty_signature _ -> Types.Tmty_signature []
-    | Types.Tmty_functor (id, mt1, mt2) ->
-        Types.Tmty_functor (id, iter mt1, iter mt2)
+let split_string s chars =
+  let len = String.length s in
+  let rec iter acc pos =
+    if pos >= len then
+      match acc with
+	"" -> []
+      |	_ -> [acc]
+    else
+      if List.mem s.[pos] chars then
+	match acc with
+	  "" -> iter "" (pos + 1)
+	| _ -> acc :: (iter "" (pos + 1))
+      else
+	iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1)
   in
-  iter t
+  iter "" 0
 
-let string_of_module_type ?(complete=false) t =
-  let t2 = if complete then t else simpl_module_type t in
-  Printtyp.modtype Format.str_formatter t2;
-  let s = Format.flush_str_formatter () in
-  s
+let split_with_blanks s = split_string s [' ' ; '\n' ; '\r' ; '\t' ]
 
-
-(** Return the given class type where methods and vals have been removed
-   from the signatures. Used when we don't want to print a too long class type.*)
-let simpl_class_type t =
-  let rec iter t =
-    match t with
-      Types.Tcty_constr (p,texp_list,ct) -> t
-    | Types.Tcty_signature cs ->
-        (* on vire les vals et methods pour ne pas qu'elles soient imprimées
-           quand on affichera le type *)
-        let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
-        Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with 
-                                                  Types.desc = Types.Tobject (tnil, ref None) };
-                               Types.cty_vars = Types.Vars.empty ;
-                               Types.cty_concr = Types.Concr.empty ;
-                             }
-    | Types.Tcty_fun (l, texp, ct) ->
-        let new_ct = iter ct in
-        Types.Tcty_fun (l, texp, new_ct)
+let list_concat sep =
+  let rec iter = function
+      [] -> []
+    | [h] -> [h]
+    | h :: q -> h :: sep :: q
   in
-  iter t
+  iter
 
-let string_of_class_type ?(complete=false) t = 
-  let t2 = if complete then t else simpl_class_type t in
-  (* A VOIR : ma propre version de Printtyp.class_type pour ne pas faire reset_names *)
-  Printtyp.class_type Format.str_formatter t2;
-  let s = Format.flush_str_formatter () in
-  s
+let string_of_longident li = String.concat "." (Longident.flatten li)
 
 let get_fields type_expr =
   let (fields, _) = Ctype.flatten_fields (Ctype.object_fields type_expr) in
@@ -143,6 +115,13 @@ let rec string_of_text t =
           "^{"^(string_of_text t)^"}"
       | Odoc_types.Subscript t ->
           "^{"^(string_of_text t)^"}"
+      |	Odoc_types.Module_list l ->
+	  string_of_text
+	    (list_concat (Odoc_types.Raw ", ")
+	       (List.map (fun s -> Odoc_types.Code s) l)
+	    )
+      |	Odoc_types.Index_list ->
+	  "" 
   in
   String.concat "" (List.map iter t)
 
@@ -276,6 +255,13 @@ let rec text_no_title_no_list t =
     | Odoc_types.Link (s, t) -> [Odoc_types.Link (s, (text_no_title_no_list t))]
     | Odoc_types.Superscript t -> [Odoc_types.Superscript (text_no_title_no_list t)]
     | Odoc_types.Subscript t -> [Odoc_types.Subscript (text_no_title_no_list t)]
+    | Odoc_types.Module_list l ->
+	list_concat (Odoc_types.Raw ", ") 
+	  (List.map
+	     (fun s -> Odoc_types.Ref (s, Some Odoc_types.RK_module))
+	     l
+	  )
+    | Odoc_types.Index_list -> []
   in
   List.flatten (List.map iter t)
 
@@ -303,6 +289,8 @@ let get_titles_in_text t =
     | Odoc_types.Link (_, t)
     | Odoc_types.Superscript t 
     | Odoc_types.Subscript t  -> iter_text t
+    | Odoc_types.Module_list _ -> ()
+    | Odoc_types.Index_list -> ()
   and iter_text te = 
     List.iter iter_ele te
   in
@@ -384,8 +372,9 @@ and first_sentence_text_ele text_ele =
   | Odoc_types.Link _ 
   | Odoc_types.Ref _ 
   | Odoc_types.Superscript _ 
-  | Odoc_types.Subscript _ -> (false, text_ele, None)
-
+  | Odoc_types.Subscript _ 
+  | Odoc_types.Module_list _ 
+  | Odoc_types.Index_list -> (false, text_ele, None)
 
 let first_sentence_of_text t = 
   let (_,t2,_) = first_sentence_text t in 
@@ -450,3 +439,5 @@ let remove_option typ =
     | Types.Tsubst t2 -> iter t2.Types.desc
   in
   { typ with Types.desc = iter typ.Types.desc }
+
+(* eof $Id: odoc_misc.ml,v 1.17 2004/05/23 10:41:50 guesdon Exp $ *)
diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli
index caa1b0a2..5083c35c 100644
--- a/ocamldoc/odoc_misc.mli
+++ b/ocamldoc/odoc_misc.mli
@@ -9,31 +9,19 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_misc.mli,v 1.10 2004/05/23 10:41:50 guesdon Exp $ *)
 
 (** Miscelaneous functions *)
 
 (** This function returns a file in the form of one string.*)
 val input_file_as_string : string -> string
 
+(** [split_with_blanks s] splits the given string [s] according to blanks. *)
+val split_with_blanks : string -> string list
+
 (** This function creates a string from a Longident.t .*)
 val string_of_longident : Longident.t -> string
 
-(** This function takes a Types.type_expr and returns a string. 
-   It writes in and flushes [Format.str_formatter].*)
-val string_of_type_expr : Types.type_expr -> string
-
-(** This function returns a string representing a [Types.module_type]. 
-   @param complete indicates if we must print complete signatures
-   or just [sig end]. Default if [false].
-*)
-val string_of_module_type : ?complete: bool -> Types.module_type -> string
-
-(** This function returns a string representing a [Types.class_type]. 
-   @param complete indicates if we must print complete signatures
-   or just [object end]. Default if [false].
-*)
-val string_of_class_type : ?complete: bool -> Types.class_type -> string
-
 (** This function returns the list of (label, type_expr) describing
    the methods of a type_expr in a Tobject.*)
 val get_fields : Types.type_expr -> (string * Types.type_expr) list
diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml
index b555e8a4..d0fdb163 100644
--- a/ocamldoc/odoc_module.ml
+++ b/ocamldoc/odoc_module.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_module.ml,v 1.9.4.1 2004/06/25 13:39:17 guesdon Exp $ *)
 
 (** Representation and manipulation of modules and module types. *)
 
@@ -36,6 +37,7 @@ and mmt =
 and included_module = {
     im_name : Name.t ; (** the name of the included module *)
     mutable im_module : mmt option ; (** the included module or module type *)
+    mutable im_info : Odoc_types.info option ; (** comment associated to the includ directive *)
   } 
 
 and module_alias = {
@@ -43,11 +45,18 @@ and module_alias = {
     mutable ma_module : mmt option ; (** the real module or module type if we could associate it *)
   } 
 
+and module_parameter = {
+    mp_name : string ; (** the name *)
+    mp_type : Types.module_type ; (** the type *)
+    mp_type_code : string ; (** the original code *)
+    mp_kind : module_type_kind ; (** the way the parameter was built *)
+  } 
+
 (** Different kinds of module. *)
 and module_kind =
   | Module_struct of module_element list 
   | Module_alias of module_alias (** complete name and corresponding module if we found it *)
-  | Module_functor of (Odoc_parameter.module_parameter list) * module_kind
+  | Module_functor of module_parameter * module_kind
   | Module_apply of module_kind * module_kind
   | Module_with of module_type_kind * string
   | Module_constraint of module_kind * module_type_kind
@@ -62,6 +71,8 @@ and t_module = {
     mutable m_kind : module_kind ;
     mutable m_loc : Odoc_types.location ;
     mutable m_top_deps : Name.t list ; (** The toplevels module names this module depends on. *)
+    mutable m_code : string option ; (** The whole code of the module *)
+    mutable m_code_intf : string option ; (** The whole code of the interface of the module *)
   } 
 
 and module_type_alias = {
@@ -72,7 +83,7 @@ and module_type_alias = {
 (** Different kinds of module type. *)
 and module_type_kind =
   | Module_type_struct of module_element list 
-  | Module_type_functor of (Odoc_parameter.module_parameter list) * module_type_kind
+  | Module_type_functor of module_parameter * module_type_kind
   | Module_type_alias of module_type_alias (** complete name and corresponding module type if we found it *)
   | Module_type_with of module_type_kind * string (** the module type kind and the code of the with constraint *)
 
@@ -194,44 +205,55 @@ let included_modules l =
    @param trans indicates if, for aliased modules, we must perform a transitive search.*)
 let rec module_elements ?(trans=true) m =
   let rec iter_kind = function
-    Module_struct l -> l
-  | Module_alias ma -> 
-      if trans then
-        match ma.ma_module with
-          None -> []
-        | Some (Mod m) -> module_elements m
-        | Some (Modtype mt) -> module_type_elements mt
-      else
-        []
-  | Module_functor (_, k) 
-  | Module_apply (k, _) -> iter_kind k
-  | Module_with (tk,_) ->
-      module_type_elements ~trans: trans
-        { mt_name = "" ; mt_info = None ; mt_type = None ;
-          mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
-          mt_loc = Odoc_types.dummy_loc ;
-        }
-  | Module_constraint (k, tk) ->
+      Module_struct l -> 
+	print_DEBUG "Odoc_module.module_element: Module_struct";
+	l
+    | Module_alias ma -> 
+	print_DEBUG "Odoc_module.module_element: Module_alias";
+	if trans then
+          match ma.ma_module with
+            None -> []
+          | Some (Mod m) -> module_elements m
+          | Some (Modtype mt) -> module_type_elements mt
+	else
+          []
+    | Module_functor (_, k) 
+    | Module_apply (k, _) -> 
+	print_DEBUG "Odoc_module.module_element: Module_functor ou Module_apply";
+	iter_kind k
+    | Module_with (tk,_) ->
+	print_DEBUG "Odoc_module.module_element: Module_with";
+	module_type_elements ~trans: trans
+          { mt_name = "" ; mt_info = None ; mt_type = None ;
+            mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
+            mt_loc = Odoc_types.dummy_loc ;
+          }
+    | Module_constraint (k, tk) ->
+	print_DEBUG "Odoc_module.module_element: Module_constraint";
       (* A VOIR : utiliser k ou tk ? *)
-      module_elements ~trans: trans
-        { m_name = "" ; m_info = None ; m_type = Types.Tmty_signature [] ;
-          m_is_interface = false ; m_file = "" ; m_kind = k ;
-          m_loc = Odoc_types.dummy_loc ;
-          m_top_deps = [] ;
-        }
+	module_elements ~trans: trans
+          { m_name = "" ; 
+	    m_info = None ; 
+	    m_type = Types.Tmty_signature [] ;
+            m_is_interface = false ; m_file = "" ; m_kind = k ;
+            m_loc = Odoc_types.dummy_loc ;
+            m_top_deps = [] ;
+	    m_code = None ;
+	    m_code_intf = None ;
+          }
 (*
-      module_type_elements ~trans: trans
-        { mt_name = "" ; mt_info = None ; mt_type = None ;
-          mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
-          mt_loc = Odoc_types.dummy_loc }
+   module_type_elements ~trans: trans
+   { mt_name = "" ; mt_info = None ; mt_type = None ;
+   mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
+   mt_loc = Odoc_types.dummy_loc }
 *)
   in
   iter_kind m.m_kind 
 
 (** Returns the list of elements of a module type. 
-  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+   @param trans indicates if, for aliased modules, we must perform a transitive search.*)
 and module_type_elements ?(trans=true) mt =
-   let rec iter_kind = function
+  let rec iter_kind = function
     | None -> []
     | Some (Module_type_struct l) -> l
     | Some (Module_type_functor (_, k)) -> iter_kind (Some k)
@@ -241,12 +263,12 @@ and module_type_elements ?(trans=true) mt =
         else
           []
     | Some (Module_type_alias mta) -> 
-       if trans then
-         match mta.mta_module with
-           None -> []
-         | Some mt -> module_type_elements mt
-       else
-        []
+	if trans then
+          match mta.mta_module with
+            None -> []
+          | Some mt -> module_type_elements mt
+	else
+          []
   in
   iter_kind mt.mt_kind
 
@@ -305,25 +327,21 @@ let module_comments ?(trans=true) m = comments (module_elements ~trans m)
 let rec module_type_parameters ?(trans=true) mt =
   let rec iter k =
     match k with
-      Some (Module_type_functor (params, _)) -> 
-        (
-         (* we create the couple (parameter, description opt), using
-            the description of the parameter if we can find it in the comment.*)
-         match mt.mt_info with
-           None ->
-             List.map (fun p -> (p, None)) params
-         | Some i ->
-             List.map 
-               (fun p ->
-                 try
-                   let d = List.assoc p.Odoc_parameter.mp_name i.Odoc_types.i_params in
-                   (p, Some d)
-                 with
-                   Not_found ->
-                     (p, None)
-               )
-               params
-        )
+      Some (Module_type_functor (p, k2)) -> 
+        let param =
+           (* we create the couple (parameter, description opt), using
+              the description of the parameter if we can find it in the comment.*)
+          match mt.mt_info with
+            None -> (p, None)
+          | Some i ->
+              try
+                let d = List.assoc p.mp_name i.Odoc_types.i_params in
+                (p, Some d)
+              with
+                Not_found ->
+                  (p, None)
+	in
+        param :: (iter (Some k2))
     | Some (Module_type_alias mta) ->
         if trans then
           match mta.mta_module with
@@ -344,45 +362,44 @@ let rec module_type_parameters ?(trans=true) mt =
   iter mt.mt_kind
 
 (** Access to the parameters, for a functor.
-  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+   @param trans indicates if, for aliased modules, we must perform a transitive search.*)
 and module_parameters ?(trans=true) m =
-  match m.m_kind with
-    Module_functor (params, _) -> 
-      (
-       (* we create the couple (parameter, description opt), using
-          the description of the parameter if we can find it in the comment.*)
-       match m.m_info with
-         None ->
-           List.map (fun p -> (p, None)) params
-       | Some i ->
-           List.map 
-             (fun p ->
-              try
-                let d = List.assoc p.Odoc_parameter.mp_name i.Odoc_types.i_params in
-                (p, Some d)
+  let rec iter = function
+      Module_functor (p, k) -> 
+	let param = 
+         (* we create the couple (parameter, description opt), using
+            the description of the parameter if we can find it in the comment.*)
+	  match m.m_info with
+            None ->(p, None)
+	  | Some i ->
+	      try
+		let d = List.assoc p.mp_name i.Odoc_types.i_params in
+		(p, Some d)
               with
-                Not_found ->
+		Not_found ->
                   (p, None)
-             )
-             params
-      )
-  | Module_alias ma ->
-      if trans then
-        match ma.ma_module with
-          None -> []
-        | Some (Mod m) -> module_parameters ~trans m
-        | Some (Modtype mt) -> module_type_parameters ~trans mt
-      else
-        []
-  | Module_constraint (k, tk) ->
-      module_type_parameters ~trans: trans
-        { mt_name = "" ; mt_info = None ; mt_type = None ;
-          mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
-          mt_loc = Odoc_types.dummy_loc }
-  | Module_struct _ 
-  | Module_apply _ 
-  | Module_with _ ->
-      []
+	in
+	param :: (iter k)
+
+    | Module_alias ma ->
+	if trans then
+          match ma.ma_module with
+            None -> []
+          | Some (Mod m) -> module_parameters ~trans m
+          | Some (Modtype mt) -> module_type_parameters ~trans mt
+	else
+          []
+    | Module_constraint (k, tk) ->
+	module_type_parameters ~trans: trans
+          { mt_name = "" ; mt_info = None ; mt_type = None ;
+            mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
+            mt_loc = Odoc_types.dummy_loc }
+    | Module_struct _ 
+    | Module_apply _ 
+    | Module_with _ ->
+	[]
+  in
+  iter m.m_kind
 
 (** access to all submodules and sudmobules of submodules ... of the given module.
   @param trans indicates if, for aliased modules, we must perform a transitive search.*)
@@ -412,18 +429,21 @@ let rec module_type_is_functor mt =
   iter mt.mt_kind
 
 (** The module is a functor if is defined as a functor or if it is an alias for a functor. *)
-let rec module_is_functor m = 
-  match m.m_kind with
-    Module_functor _ -> true
-  | Module_alias ma ->
-      (
-       match ma.ma_module with
-         None -> false 
-       | Some (Mod mo) -> module_is_functor mo
-       | Some (Modtype mt) -> module_type_is_functor mt
-      )
-  | _ -> false
-
+let module_is_functor m = 
+  let rec iter = function
+      Module_functor _ -> true
+    | Module_alias ma ->
+	(
+	 match ma.ma_module with
+           None -> false 
+	 | Some (Mod mo) -> iter mo.m_kind
+	 | Some (Modtype mt) -> module_type_is_functor mt
+	)
+    | Module_constraint (k, _) ->
+	iter k
+    | _ -> false
+  in
+  iter m.m_kind
 
 (** Returns the list of values of a module type. 
   @param trans indicates if, for aliased modules, we must perform a transitive search.*)
diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml
index 188d3fb0..8f7a03bc 100644
--- a/ocamldoc/odoc_name.ml
+++ b/ocamldoc/odoc_name.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_name.ml,v 1.9 2004/03/26 09:09:50 guesdon Exp $ *)
 
 (** Representation of element names. *)
 
@@ -59,7 +60,7 @@ let cut name =
                      '(' -> 
                        j := 1
                    | _ ->
-                       Buffer.add_char buf.(!j) '('
+                       Buffer.add_char buf.(!j) '.'
                  else
                    Buffer.add_char buf.(!j) s.[i]
              | c ->
@@ -78,10 +79,28 @@ let father name = fst (cut name)
 
 let concat n1 n2 = n1^"."^n2
 
-let head n =
-  match Str.split (Str.regexp "\\.") n with
-    [] -> n
-  | h :: _ -> h
+let head_and_tail n =
+  try
+    let pos = String.index n '.' in
+    if pos > 0 then
+      let h = String.sub n 0 pos in
+      try
+	ignore (String.index h '(');
+	(n, "")
+      with
+	Not_found ->
+	  let len = String.length n in
+	  if pos >= (len - 1) then
+	    (h, "")
+	  else
+	    (h, String.sub n (pos + 1) (len - pos - 1))
+    else
+      (n, "")
+  with
+    Not_found -> (n, "")
+
+let head n = fst (head_and_tail n)
+let tail n = snd (head_and_tail n)
 
 let depth name =
   try
@@ -97,6 +116,20 @@ let prefix n1 n2 =
     (n2.[len1] = '.')
   with _ -> false)
 
+let rec get_relative_raw n1 n2 =
+  let (f1,s1) = head_and_tail n1 in
+  let (f2,s2) = head_and_tail n2 in
+  if f1 = f2 then
+    if f2 = s2 or s2 = "" then
+      s2
+    else
+      if f1 = s1 or s1 = "" then
+	s2
+      else
+	get_relative_raw s1 s2
+  else
+    n2
+
 let get_relative n1 n2 =
   if prefix n1 n2 then
     let len1 = String.length n1 in
@@ -141,21 +174,3 @@ let to_path n =
 
 let from_longident longident = String.concat "." (Longident.flatten longident)
 
-let name_alias name cpl_aliases =
-  let rec f n1 = function
-      [] -> raise Not_found
-    | (n2, n3) :: q ->
-        if n2 = n1 then 
-          n3
-        else
-          if prefix n2 n1 then
-            let ln2 = String.length n2 in
-            n3^(String.sub n1 ln2 ((String.length n1) - ln2))
-          else
-            f n1 q
-  in
-  let rec iter n =
-    try iter (f n cpl_aliases)
-    with Not_found -> n
-  in
-  iter name
diff --git a/ocamldoc/odoc_name.mli b/ocamldoc/odoc_name.mli
index 6319b40e..539dfbaa 100644
--- a/ocamldoc/odoc_name.mli
+++ b/ocamldoc/odoc_name.mli
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_name.mli,v 1.4 2004/03/26 09:09:50 guesdon Exp $ *)
 
 (** Representation of element names. *)
 
@@ -40,9 +41,12 @@ val prefix : t -> t -> bool
 (** Take two names n1 and n2 = n3.n4 and return n4 if n3=n1 or else n2. *)
 val get_relative : t -> t -> t
 
+(** Take two names n1=n3.n4 and n2 = n5.n6 and return n6 if n3=n5 or else n2. *)
+val get_relative_raw : t -> t -> t
+
 (** Take a list of module names to hide and a name,
    and return the name when the module name (or part of it)
-   was removedn, according to the list of module names to hide.*)
+   was removed, according to the list of module names to hide.*)
 val hide_given_modules : t list -> t -> t
 
 (** Indicate if a name if qualified or not. *)
@@ -60,6 +64,3 @@ val to_path : t -> Path.t
 (** Get a name from a [Longident.t].*)
 val from_longident : Longident.t -> t
 
-(** This function takes a name and a list of name aliases and returns the name
-   after substitution using the aliases. *)
-val name_alias : t -> (t * t) list -> t
diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll
index 12f8af37..e5b50c6e 100644
--- a/ocamldoc/odoc_ocamlhtml.mll
+++ b/ocamldoc/odoc_ocamlhtml.mll
@@ -11,6 +11,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_ocamlhtml.mll,v 1.9 2004/03/14 13:52:01 guesdon Exp $ *)
+
 (** Generation of html code to display OCaml code. *)
 open Lexing 
 
@@ -203,25 +205,12 @@ let get_stored_string () =
 
 (** To translate escape sequences *)
 
-let char_for_backslash =
-  match Sys.os_type with
-  | "Unix" | "Win32" | "Cygwin" ->
-      begin function
-      | 'n' -> '\010'
-      | 'r' -> '\013'
-      | 'b' -> '\008'
-      | 't' -> '\009'
-      | c   -> c
-      end
-  | "MacOS" ->
-      begin function
-      | 'n' -> '\013'
-      | 'r' -> '\010'
-      | 'b' -> '\008'
-      | 't' -> '\009'
-      | c   -> c
-      end
-  | x -> fatal_error "Lexer: unknown system type"
+let char_for_backslash = function
+  | 'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
 
 let char_for_decimal_code lexbuf i =
   let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
@@ -498,7 +487,7 @@ and string = parse
         string lexbuf }
 {
 
-let html_of_code ?(with_pre=true) code =
+let html_of_code b ?(with_pre=true) code =
   let old_pre = !pre in
   let old_margin = !margin in
   let old_comment_buffer = Buffer.contents comment_buffer in
@@ -509,7 +498,6 @@ let html_of_code ?(with_pre=true) code =
   pre := with_pre;
   margin := 0;
   
-
   let start = "<code class=\""^code_class^"\">" in
   let ending = "</code>" in
   let html = 
@@ -537,6 +525,6 @@ let html_of_code ?(with_pre=true) code =
   Buffer.add_string string_buffer old_string_buffer ;
   fmt := old_fmt ;
 
-  html
+  Buffer.add_string b html
 
 } 
diff --git a/ocamldoc/odoc_parameter.ml b/ocamldoc/odoc_parameter.ml
index 1cd5cac5..51c442a8 100644
--- a/ocamldoc/odoc_parameter.ml
+++ b/ocamldoc/odoc_parameter.ml
@@ -9,9 +9,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_parameter.ml,v 1.8 2004/04/02 15:10:57 guesdon Exp $ *)
 
-(** Representation and manipulation of method / function / class parameters,
-   and module parameters.*)
+(** Representation and manipulation of method / function / class parameters. *)
 
 let print_DEBUG s = print_string s ; print_newline ()
 
@@ -33,13 +33,6 @@ type param_info =
 (** A parameter is just a param_info.*)
 type parameter = param_info
 
-(** A module parameter is just a name and a module type.*)
-type module_parameter = {
-    mp_name : string ;
-    mp_type : Types.module_type ;
-  } 
-
-
 (** Functions *)
 
 (** acces to the name as a string. For tuples, parenthesis and commas are added. *)
diff --git a/ocamldoc/odoc_parser.mly b/ocamldoc/odoc_parser.mly
index 13e11110..550ded05 100644
--- a/ocamldoc/odoc_parser.mly
+++ b/ocamldoc/odoc_parser.mly
@@ -10,6 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_parser.mly,v 1.3 2003/11/24 10:43:11 starynke Exp $ *)
+
 open Odoc_types
 open Odoc_comments_global
 
diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml
new file mode 100644
index 00000000..5be5cfeb
--- /dev/null
+++ b/ocamldoc/odoc_print.ml
@@ -0,0 +1,104 @@
+(***********************************************************************)
+(*                             OCamldoc                                *)
+(*                                                                     *)
+(*            Maxence Guesdon, 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: odoc_print.ml,v 1.3 2004/05/18 13:28:00 garrigue Exp $ *)
+
+open Format
+
+let new_fmt () =
+  let buf = Buffer.create 512 in
+  let fmt = formatter_of_buffer buf in
+  let flush () =
+    pp_print_flush fmt ();
+    let s = Buffer.contents buf in
+    Buffer.reset buf ;
+    s 
+  in
+  (fmt, flush)
+
+let (type_fmt, flush_type_fmt) = new_fmt ()
+let _ =
+  let (out, flush, outnewline, outspace) = 
+    pp_get_all_formatter_output_functions type_fmt () 
+  in
+  pp_set_all_formatter_output_functions type_fmt
+    ~out ~flush
+    ~newline: (fun () -> out "\n  " 0 3)
+    ~spaces: outspace
+
+let (modtype_fmt, flush_modtype_fmt) = new_fmt ()
+
+
+
+
+let string_of_type_expr t =
+  Printtyp.mark_loops t;
+  Printtyp.type_scheme_max ~b_reset_names: false type_fmt t;
+  flush_type_fmt ()
+
+exception Use_code of string
+
+(** Return the given module type where methods and vals have been removed
+   from the signatures. Used when we don't want to print a too long module type.
+   @param code when the code is given, we raise the [Use_code] exception is we
+   encouter a signature, to that the calling function can use the code rather
+   than the "emptied" type.
+*)
+let simpl_module_type ?code t =
+  let rec iter t =
+    match t with
+      Types.Tmty_ident p -> t
+    | Types.Tmty_signature _ -> 
+	(
+	 match code with
+	   None -> Types.Tmty_signature []
+	 | Some s -> raise (Use_code s)
+	)
+    | Types.Tmty_functor (id, mt1, mt2) ->
+        Types.Tmty_functor (id, iter mt1, iter mt2)
+  in
+  iter t
+
+let string_of_module_type ?code ?(complete=false) t =
+  try
+    let t2 = if complete then t else simpl_module_type ?code t in
+    Printtyp.modtype modtype_fmt t2;
+    flush_modtype_fmt ()
+  with
+    Use_code s -> s
+
+(** Return the given class type where methods and vals have been removed
+   from the signatures. Used when we don't want to print a too long class type.*)
+let simpl_class_type t =
+  let rec iter t =
+    match t with
+      Types.Tcty_constr (p,texp_list,ct) -> t
+    | Types.Tcty_signature cs ->
+        (* on vire les vals et methods pour ne pas qu'elles soient imprimées
+           quand on affichera le type *)
+        let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
+        Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with 
+                                                  Types.desc = Types.Tobject (tnil, ref None) };
+                               Types.cty_vars = Types.Vars.empty ;
+                               Types.cty_concr = Types.Concr.empty ;
+                               Types.cty_inher = []
+                             }
+    | Types.Tcty_fun (l, texp, ct) ->
+        let new_ct = iter ct in
+        Types.Tcty_fun (l, texp, new_ct)
+  in
+  iter t
+
+let string_of_class_type ?(complete=false) t = 
+  let t2 = if complete then t else simpl_class_type t in
+  (* A VOIR : ma propre version de Printtyp.class_type pour ne pas faire reset_names *)
+  Printtyp.class_type modtype_fmt t2;
+  flush_modtype_fmt ()
diff --git a/ocamldoc/odoc_print.mli b/ocamldoc/odoc_print.mli
new file mode 100644
index 00000000..e825b6e4
--- /dev/null
+++ b/ocamldoc/odoc_print.mli
@@ -0,0 +1,33 @@
+(***********************************************************************)
+(*                             OCamldoc                                *)
+(*                                                                     *)
+(*            Maxence Guesdon, 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: odoc_print.mli,v 1.2 2004/03/26 09:09:50 guesdon Exp $ *)
+
+(** Printing functions. *)
+
+(** This function takes a Types.type_expr and returns a string. 
+   It writes in and flushes [Format.str_formatter].*)
+val string_of_type_expr : Types.type_expr -> string
+
+(** This function returns a string representing a [Types.module_type]. 
+   @param complete indicates if we must print complete signatures
+   or just [sig end]. Default if [false].
+   @param code if [complete = false] and the type contains something else
+   than identificators and functors, then the given code is used.
+*)
+val string_of_module_type : ?code: string -> ?complete: bool -> Types.module_type -> string
+
+(** This function returns a string representing a [Types.class_type]. 
+   @param complete indicates if we must print complete signatures
+   or just [object end]. Default if [false].
+*)
+val string_of_class_type : ?complete: bool -> Types.class_type -> string
+
diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml
index 96abc22f..1b669e15 100644
--- a/ocamldoc/odoc_scan.ml
+++ b/ocamldoc/odoc_scan.ml
@@ -9,6 +9,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_scan.ml,v 1.3 2003/11/24 10:43:11 starynke Exp $ *)
+
 (** Scanning of modules and elements.
 
    The class scanner defined in this module can be used to
diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml
index ef81d931..5770aef6 100644
--- a/ocamldoc/odoc_search.ml
+++ b/ocamldoc/odoc_search.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_search.ml,v 1.6 2004/05/23 10:41:50 guesdon Exp $ *)
 
 (** Research of elements through modules. *)
 
@@ -78,7 +79,9 @@ module Search =
       | T.Link (_, t) -> search_text root t v
       | T.List l 
       | T.Enum l -> List.flatten (List.map (fun t -> search_text root t v) l)
-      | T.Newline -> []
+      | T.Newline 
+      |	T.Module_list _
+      |	T.Index_list -> []
       | T.Title (n, l_opt, t) -> 
           (match l_opt with
             None -> []
@@ -627,3 +630,5 @@ let find_section mods regexp =
   with
     Res_section (_,t) -> t
   | _ -> assert false
+
+(* eof $Id: odoc_search.ml,v 1.6 2004/05/23 10:41:50 guesdon Exp $ *)
diff --git a/ocamldoc/odoc_search.mli b/ocamldoc/odoc_search.mli
index f7f8c61f..4254af07 100644
--- a/ocamldoc/odoc_search.mli
+++ b/ocamldoc/odoc_search.mli
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_search.mli,v 1.4 2003/11/24 10:43:12 starynke Exp $ *)
 
 (** Research of elements through modules. *)
 
diff --git a/ocamldoc/odoc_see_lexer.mll b/ocamldoc/odoc_see_lexer.mll
index 8e7dfcd4..fe16fee2 100644
--- a/ocamldoc/odoc_see_lexer.mll
+++ b/ocamldoc/odoc_see_lexer.mll
@@ -10,6 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_see_lexer.mll,v 1.3 2003/11/24 10:43:12 starynke Exp $ *)
+
 let print_DEBUG2 s = print_string s ; print_newline ()
 
 (** the lexer for special comments. *)
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index ede23eff..659874da 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_sig.ml,v 1.30.2.2 2004/07/02 12:59:48 guesdon Exp $ *)
 
 (** Analysis of interface files. *)
 
@@ -50,13 +51,13 @@ module Signature_search =
           Hashtbl.add table (V (Name.from_ident ident)) signat
       | Types.Tsig_exception (ident, _) ->
           Hashtbl.add table (E (Name.from_ident ident)) signat
-      | Types.Tsig_type (ident, _) ->
+      | Types.Tsig_type (ident, _, _) ->
           Hashtbl.add table (T (Name.from_ident ident)) signat
-      | Types.Tsig_class (ident,_) ->
+      | Types.Tsig_class (ident, _, _) ->
           Hashtbl.add table (C (Name.from_ident ident)) signat
-      | Types.Tsig_cltype (ident, _) ->
+      | Types.Tsig_cltype (ident, _, _) ->
           Hashtbl.add table (CT (Name.from_ident ident)) signat
-      | Types.Tsig_module (ident, _) ->
+      | Types.Tsig_module (ident, _, _) ->
           Hashtbl.add table (M (Name.from_ident ident)) signat
       | Types.Tsig_modtype (ident,_) ->
           Hashtbl.add table (MT (Name.from_ident ident)) signat
@@ -79,22 +80,22 @@ module Signature_search =
 
     let search_type table name =
       match Hashtbl.find table (T name) with
-      | (Types.Tsig_type (_, type_decl)) -> type_decl
+      | (Types.Tsig_type (_, type_decl, _)) -> type_decl
       | _ -> assert false
 
     let search_class table name =
       match Hashtbl.find table (C name) with
-      | (Types.Tsig_class (_, class_decl)) -> class_decl
+      | (Types.Tsig_class (_, class_decl, _)) -> class_decl
       | _ -> assert false
 
     let search_class_type table name =
       match Hashtbl.find table (CT name) with
-      | (Types.Tsig_cltype (_, cltype_decl)) -> cltype_decl
+      | (Types.Tsig_cltype (_, cltype_decl, _)) -> cltype_decl
       | _ -> assert false
 
     let search_module table name =
       match Hashtbl.find table (M name) with
-      | (Types.Tsig_module (ident, module_type)) -> module_type
+      | (Types.Tsig_module (ident, module_type, _)) -> module_type
       | _ -> assert false
 
     let search_module_type table name =
@@ -284,7 +285,7 @@ module Analyser =
       let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in
       Types.Vars.iter f_DEBUG class_signature.Types.cty_vars;
       print_DEBUG ("Type de la classe "^current_class_name^" : ");
-      print_DEBUG (Odoc_misc.string_of_type_expr class_signature.Types.cty_self);
+      print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self);
       let get_pos_limit2 q =
         match q with
           [] -> pos_limit
@@ -331,7 +332,6 @@ module Analyser =
         met.met_value.val_info <- merge_infos met.met_value.val_info info_after_opt ;
         (* update the parameter description *)
         Odoc_value.update_value_parameters_text met.met_value;
-
         (met, maybe_more)
       in
       let rec f last_pos class_type_field_list =
@@ -556,7 +556,7 @@ module Analyser =
 		ex_code = 
 		   (
                     if !Odoc_args.keep_code then
-                      Some (get_string_of_file pos_start_ele (pos_end_ele + pos_limit))
+                      Some (get_string_of_file pos_start_ele pos_end_ele)
                     else
                       None
                    ) ;
@@ -685,6 +685,15 @@ module Analyser =
                 raise (Failure (Odoc_messages.module_not_found current_module_name name))
             in
             let module_kind = analyse_module_kind env complete_name module_type sig_module_type in
+	    let code_intf = 
+	      if !Odoc_args.keep_code then
+		let loc = module_type.Parsetree.pmty_loc in
+		let st = loc.Location.loc_start.Lexing.pos_cnum in
+		let en = loc.Location.loc_end.Lexing.pos_cnum in
+		Some (get_string_of_file st en)
+	      else
+		None
+	    in
             let new_module = 
               {
                 m_name = complete_name ;
@@ -695,6 +704,8 @@ module Analyser =
                 m_kind = module_kind ;
                 m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
                 m_top_deps = [] ;
+		m_code = None ;
+		m_code_intf = code_intf ;
               } 
             in
             let (maybe_more, info_after_opt) = 
@@ -764,6 +775,15 @@ module Analyser =
                   in
                   (* associate the comments to each constructor and build the [Type.t_type] *)
 		  let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in
+		  let code_intf = 
+		    if !Odoc_args.keep_code then
+		      let loc = modtype.Parsetree.pmty_loc in
+		      let st = loc.Location.loc_start.Lexing.pos_cnum in
+		      let en = loc.Location.loc_end.Lexing.pos_cnum in
+		      Some (get_string_of_file st en)
+		    else
+		      None
+		  in
 		  let new_module = 
 		    {
                       m_name = complete_name ;
@@ -774,6 +794,8 @@ module Analyser =
                       m_kind = module_kind ;
                       m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
                       m_top_deps = [] ;
+		      m_code = None ;
+		      m_code_intf = code_intf ;
 		    } 
 		  in
 		  let (maybe_more, info_after_opt) = 
@@ -868,10 +890,13 @@ module Analyser =
               | Parsetree.Pmty_with (mt, _) ->
                   f mt.Parsetree.pmty_desc
             in
+	    let name = (f module_type.Parsetree.pmty_desc) in
+	    let full_name = Odoc_env.full_module_or_module_type_name env name in
             let im = 
               {
-                im_name = Odoc_env.full_module_or_module_type_name env (f module_type.Parsetree.pmty_desc) ;
+                im_name = full_name ;
                 im_module = None ;
+		im_info = comment_opt;
               } 
             in
             (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
@@ -1051,23 +1076,31 @@ module Analyser =
                raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat")
           )
             
-      | Parsetree.Pmty_functor (_,_, module_type2) ->
+      | Parsetree.Pmty_functor (_,pmodule_type2, module_type2) ->
           (
+	   let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
+           let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+	   let mp_type_code = get_string_of_file loc_start loc_end in
+	   print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
            match sig_module_type with
              Types.Tmty_functor (ident, param_module_type, body_module_type) ->
+	       let mp_kind = analyse_module_type_kind env 
+		   current_module_name pmodule_type2 param_module_type 
+	       in
                let param = 
                  {
                    mp_name = Name.from_ident ident ;
                    mp_type = Odoc_env.subst_module_type env param_module_type ;
+		   mp_type_code = mp_type_code ;
+		   mp_kind = mp_kind ;
                  } 
                in
-               (
-                match analyse_module_type_kind env current_module_name module_type2 body_module_type with
-                  Module_type_functor (params, k) ->
-                    Module_type_functor (param :: params, k)
-                | k ->
-                    Module_type_functor ([param], k)
-               )
+	       let k = analyse_module_type_kind env 
+		   current_module_name 
+		   module_type2 
+		   body_module_type 
+	       in
+               Module_type_functor (param, k)
 
            | _ ->
                (* if we're here something's wrong *)
@@ -1087,15 +1120,9 @@ module Analyser =
     (** Analyse of a Parsetree.module_type and a Types.module_type.*)
     and analyse_module_kind env current_module_name module_type sig_module_type =
       match module_type.Parsetree.pmty_desc with
-        Parsetree.Pmty_ident longident (*of Longident.t*) -> 
-          let name = 
-            match sig_module_type with
-              Types.Tmty_ident path -> Name.from_path path
-            | _ -> 
-                Name.from_longident longident 
-          in
-          Module_alias { ma_name = Odoc_env.full_module_or_module_type_name env name ; 
-                         ma_module = None }
+        Parsetree.Pmty_ident longident ->
+	  let k = analyse_module_type_kind env current_module_name module_type sig_module_type in
+          Module_with ( k, "" )
 
       | Parsetree.Pmty_signature signature ->
           (
@@ -1114,23 +1141,31 @@ module Analyser =
                (* if we're here something's wrong *)
                raise (Failure "Parsetree.Pmty_signature signature but not Types.Tmty_signature signat")
           )
-      | Parsetree.Pmty_functor (_,_,module_type2) (* of string * module_type * module_type *) ->
+      | Parsetree.Pmty_functor (_,pmodule_type2,module_type2) (* of string * module_type * module_type *) ->
           (
            match sig_module_type with
              Types.Tmty_functor (ident, param_module_type, body_module_type) ->
+	       let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
+               let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+	       let mp_type_code = get_string_of_file loc_start loc_end in
+	       print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
+	       let mp_kind = analyse_module_type_kind env 
+		   current_module_name pmodule_type2 param_module_type 
+	       in
                let param = 
                  {
                    mp_name = Name.from_ident ident ;
                    mp_type = Odoc_env.subst_module_type env param_module_type ;
+		   mp_type_code = mp_type_code ;
+		   mp_kind = mp_kind ;
                  } 
                in
-               (
-                match analyse_module_kind env current_module_name module_type2 body_module_type with
-                  Module_functor (params, k) ->
-                    Module_functor (param :: params, k)
-                | k ->
-                    Module_functor ([param], k)
-               )
+               let k = analyse_module_kind env 
+		   current_module_name 
+		   module_type2 
+		   body_module_type 
+	       in
+               Module_functor (param, k)
                      
            | _ ->
                (* if we're here something's wrong *)
@@ -1170,7 +1205,7 @@ module Analyser =
           let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in
           Types.Vars.iter f_DEBUG class_signature.Types.cty_vars;
           print_DEBUG ("Type de la classe "^current_class_name^" : ");
-          print_DEBUG (Odoc_misc.string_of_type_expr class_signature.Types.cty_self);
+          print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self);
           (* we get the elements of the class in class_type_field_list *)
           let (inher_l, ele) = analyse_class_elements env current_class_name 
               last_pos
@@ -1224,7 +1259,7 @@ module Analyser =
           let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in
           Types.Vars.iter f_DEBUG class_signature.Types.cty_vars;
           print_DEBUG ("Type de la classe "^current_class_name^" : ");
-          print_DEBUG (Odoc_misc.string_of_type_expr class_signature.Types.cty_self);
+          print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self);
           (* we get the elements of the class in class_type_field_list *)
           let (inher_l, ele) = analyse_class_elements env current_class_name
               last_pos
@@ -1264,7 +1299,8 @@ module Analyser =
       | _ ->
           raise (Failure "analyse_class_type_kind pas de correspondance dans le match")
 
-    let analyse_signature source_file input_file (ast : Parsetree.signature) (signat : Types.signature) = 
+    let analyse_signature source_file input_file
+	(ast : Parsetree.signature) (signat : Types.signature) = 
       let complete_source_file =
         try
           let curdir = Sys.getcwd () in
@@ -1285,39 +1321,28 @@ module Analyser =
           (Filename.basename (try Filename.chop_extension source_file with _ -> source_file)) 
       in
       let (len,info_opt) = My_ir.first_special !file_name !file in
-      let elements = analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast in
-      let m =
-        {
-          m_name = mod_name ;
-          m_type = Types.Tmty_signature signat ;
-          m_info = info_opt ;
-          m_is_interface = true ;
-          m_file = !file_name ;
-          m_kind = Module_struct elements ;
-          m_loc = { loc_impl = None ; loc_inter = Some (!file_name, 0) } ;
-          m_top_deps = [] ;
-        } 
+      let elements = 
+	analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast 
       in
-      
-      print_DEBUG "Eléments du module:";
-      let f e =
-        let s = 
-          match e with
-            Element_module m -> "module "^m.m_name
-          | Element_module_type mt -> "module type "^mt.mt_name
-          | Element_included_module im -> "included module "^im.im_name
-          | Element_class c -> "class "^c.cl_name
-          | Element_class_type ct -> "class type "^ct.clt_name
-          | Element_value v -> "value "^v.val_name
-          | Element_exception e -> "exception "^e.ex_name
-          | Element_type t -> "type "^t.ty_name
-          | Element_module_comment t -> Odoc_misc.string_of_text t
-        in
-        print_DEBUG s;
-        ()
+      let code_intf = 
+	if !Odoc_args.keep_code then
+	  Some !file
+	else
+	  None
       in
-      List.iter f elements;
-
-      m
+      {
+        m_name = mod_name ;
+        m_type = Types.Tmty_signature signat ;
+        m_info = info_opt ;
+        m_is_interface = true ;
+        m_file = !file_name ;
+        m_kind = Module_struct elements ;
+        m_loc = { loc_impl = None ; loc_inter = Some (!file_name, 0) } ;
+        m_top_deps = [] ;
+	m_code = None ;
+	m_code_intf = code_intf ;
+      } 
           
     end
+
+(* eof $Id: odoc_sig.ml,v 1.30.2.2 2004/07/02 12:59:48 guesdon Exp $ *)
diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli
index 3530659c..9e0b735e 100644
--- a/ocamldoc/odoc_sig.mli
+++ b/ocamldoc/odoc_sig.mli
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_sig.mli,v 1.5 2003/11/24 10:43:12 starynke Exp $ *)
 
 (** The module for analysing a signature and source code and creating modules, classes, ..., elements.*)
 
diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
index 3a5cf927..ca8095e9 100644
--- a/ocamldoc/odoc_str.ml
+++ b/ocamldoc/odoc_str.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_str.ml,v 1.9 2004/03/22 15:06:31 guesdon Exp $ *)
 
 (** The functions to get a string from different kinds of elements (types, modules, ...). *)
 
@@ -55,7 +56,7 @@ let raw_string_of_type_list sep type_list =
     [] -> ()
   | [(variance, ty)] -> print_one_type variance ty
   | (variance, ty) :: tyl ->
-      Format.fprintf fmt "@[<hov 2>(";
+      Format.fprintf fmt "@[<hov 2>";
       print_one_type variance ty;
       List.iter
         (fun (variance, t) -> 
@@ -63,20 +64,56 @@ let raw_string_of_type_list sep type_list =
 	  print_one_type variance t
 	)
         tyl;
-      Format.fprintf fmt ")@]"
+      Format.fprintf fmt "@]"
   end;
   Format.pp_print_flush fmt ();
   Buffer.contents buf
 
-let string_of_type_list sep type_list =
-  raw_string_of_type_list sep (List.map (fun t -> ("", t)) type_list)
+let string_of_type_list ?par sep type_list =
+  let par =
+    match par with
+    | Some b -> b
+    | None ->
+	match type_list with
+	  [] | [_] -> false
+	| _ -> true
+  in
+  Printf.sprintf "%s%s%s"
+    (if par then "(" else "")
+    (raw_string_of_type_list sep (List.map (fun t -> ("", t)) type_list))
+    (if par then ")" else "")
 
 let string_of_type_param_list t =
-  raw_string_of_type_list ", "
-    (List.map 
-       (fun (typ, co, cn) -> (string_of_variance t (co, cn), typ))
-       t.Odoc_type.ty_parameters
+  let par = 
+    match t.Odoc_type.ty_parameters with
+      [] | [_] -> false
+    | _ -> true
+  in
+  Printf.sprintf "%s%s%s"
+    (if par then "(" else "")
+    (raw_string_of_type_list ", "
+       (List.map 
+	  (fun (typ, co, cn) -> (string_of_variance t (co, cn), typ))
+	  t.Odoc_type.ty_parameters
+       )
+    )
+    (if par then ")" else "")
+
+let string_of_class_type_param_list l =
+  let par = 
+    match l with
+      [] | [_] -> false
+    | _ -> true
+  in
+  Printf.sprintf "%s%s%s"
+    (if par then "[" else "")
+    (raw_string_of_type_list ", "
+       (List.map 
+	  (fun typ -> ("", typ))
+	  l
+       )
     )
+    (if par then "]" else "")
 
 let string_of_type t =
   let module M = Odoc_type in
@@ -85,7 +122,7 @@ let string_of_type t =
      (List.map 
         (fun (p, co, cn) -> 
 	  (string_of_variance t (co, cn))^
-	  (Odoc_misc.string_of_type_expr p)^" "
+	  (Odoc_print.string_of_type_expr p)^" "
 	)
         t.M.ty_parameters
      )
@@ -93,7 +130,7 @@ let string_of_type t =
   (Name.simple t.M.ty_name)^" "^
   (match t.M.ty_manifest with
     None -> ""
-  | Some typ -> "= "^(Odoc_misc.string_of_type_expr typ)^" "
+  | Some typ -> "= "^(Odoc_print.string_of_type_expr typ)^" "
   )^
   (match t.M.ty_kind with
     M.Type_abstract -> 
@@ -108,7 +145,7 @@ let string_of_type t =
                 [] -> "" 
               | l -> 
                   " of "^(String.concat " * " 
-                            (List.map (fun t -> "("^(Odoc_misc.string_of_type_expr t)^")") l))
+                            (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))
               )^
               (match cons.M.vc_text with
                 None ->
@@ -126,7 +163,7 @@ let string_of_type t =
          (List.map 
             (fun record ->
               "   "^(if record.M.rf_mutable then "mutable " else "")^
-              record.M.rf_name^" : "^(Odoc_misc.string_of_type_expr record.M.rf_type)^";"^
+              record.M.rf_name^" : "^(Odoc_print.string_of_type_expr record.M.rf_type)^";"^
               (match record.M.rf_text with
                 None ->
                   ""
@@ -150,7 +187,7 @@ let string_of_exception e =
     [] -> ""
   | _ ->" : "^
       (String.concat " -> " 
-         (List.map (fun t -> "("^(Odoc_misc.string_of_type_expr t)^")") e.M.ex_args)
+         (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") e.M.ex_args)
       )
   )^
   (match e.M.ex_alias with
@@ -169,7 +206,7 @@ let string_of_exception e =
 let string_of_value v =
   let module M = Odoc_value in
   "val "^(Name.simple v.M.val_name)^" : "^
-  (Odoc_misc.string_of_type_expr v.M.val_type)^"\n"^
+  (Odoc_print.string_of_type_expr v.M.val_type)^"\n"^
   (match v.M.val_info with
     None -> ""
   | Some i -> Odoc_misc.string_of_info i)
@@ -179,7 +216,7 @@ let string_of_attribute a =
   "val "^
   (if a.M.att_mutable then Odoc_messages.mutab^" " else "")^
   (Name.simple a.M.att_value.M.val_name)^" : "^
-  (Odoc_misc.string_of_type_expr a.M.att_value.M.val_type)^"\n"^
+  (Odoc_print.string_of_type_expr a.M.att_value.M.val_type)^"\n"^
   (match a.M.att_value.M.val_info with
     None -> ""
   | Some i -> Odoc_misc.string_of_info i)
@@ -189,7 +226,9 @@ let string_of_method m =
   "method "^
   (if m.M.met_private then Odoc_messages.privat^" " else "")^
   (Name.simple m.M.met_value.M.val_name)^" : "^
-  (Odoc_misc.string_of_type_expr m.M.met_value.M.val_type)^"\n"^
+  (Odoc_print.string_of_type_expr m.M.met_value.M.val_type)^"\n"^
   (match m.M.met_value.M.val_info with
     None -> ""
   | Some i -> Odoc_misc.string_of_info i)
+
+(* eof $Id: odoc_str.ml,v 1.9 2004/03/22 15:06:31 guesdon Exp $ *)
diff --git a/ocamldoc/odoc_str.mli b/ocamldoc/odoc_str.mli
index 12116f5a..df660911 100644
--- a/ocamldoc/odoc_str.mli
+++ b/ocamldoc/odoc_str.mli
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_str.mli,v 1.5 2004/03/22 15:06:31 guesdon Exp $ *)
 
 (** The functions to get a string from different kinds of elements (types, modules, ...). *)
 
@@ -16,13 +17,20 @@
 val string_of_variance : Odoc_type.t_type -> (bool * bool) -> string
 
 (** This function returns a string to represent the given list of types,
-   with a given separator. It writes in and flushes [Format.str_formatter].*)
-val string_of_type_list : string -> Types.type_expr list -> string
+   with a given separator.
+   @param par can be used to force the addition or not of parentheses around the returned string.
+*)
+val string_of_type_list : ?par: bool -> string -> Types.type_expr list -> string
 
 (** This function returns a string to represent the list of type parameters
-   for the given type. It writes in and flushes [Format.str_formatter].*)
+   for the given type. *)
 val string_of_type_param_list : Odoc_type.t_type -> string
 
+(** This function returns a string to represent the given list of 
+   type parameters of a class or class type,
+   with a given separator. *)
+val string_of_class_type_param_list : Types.type_expr list -> string
+
 (** @return a string to describe the given type. *)
 val string_of_type : Odoc_type.t_type -> string
 
diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml
new file mode 100644
index 00000000..8c2d020e
--- /dev/null
+++ b/ocamldoc/odoc_test.ml
@@ -0,0 +1,112 @@
+(***********************************************************************)
+(*                             OCamldoc                                *)
+(*                                                                     *)
+(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
+(*                                                                     *)
+(*  Copyright 2004 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: odoc_test.ml,v 1.1 2004/02/20 16:28:27 guesdon Exp $ *)
+
+(** Custom generator to perform test on ocamldoc. *)
+
+open Odoc_info
+open Odoc_info.Module
+open Odoc_info.Type
+
+type test_kind =
+    Types_display
+
+let p = Format.fprintf
+
+class string_gen =
+  object(self)
+    inherit Odoc_info.Scan.scanner
+
+    val mutable test_kinds = []
+    val mutable fmt = Format.str_formatter 
+
+    method must_display_types = List.mem Types_display test_kinds
+
+    method set_test_kinds_from_module m =
+      test_kinds <- List.fold_left
+	  (fun acc (s, _) ->
+	    match s with
+	      "test_types_display" -> Types_display :: acc
+	    | _ -> acc
+	  )
+	  []
+	  (
+	   match m.m_info with
+	     None -> []
+	   | Some i -> i.i_custom
+	  )
+    method scan_type t =
+      match test_kinds with
+	[] -> ()
+      |	_ ->
+	  p fmt "# type %s:\n" t.ty_name;
+	  if self#must_display_types then
+	    (
+	     p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n"
+	       (match t.ty_manifest with
+		 None -> "None"
+	       | Some e -> Odoc_info.string_of_type_expr e
+	       );
+	    );
+
+
+    method scan_module_pre m =
+      p fmt "#\n# module %s:\n" m.m_name ;
+      if self#must_display_types then
+	(
+	 p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n"
+	   (Odoc_info.string_of_module_type m.m_type);
+	 p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n"
+	   (Odoc_info.string_of_module_type ~complete: true m.m_type);
+	);
+      true
+
+    method scan_module_type_pre m =
+      p fmt "#\n# module type %s:\n" m.mt_name ;
+      if self#must_display_types then
+	(
+	 p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n"
+	   (match m.mt_type with
+	     None -> "None"
+	   | Some t -> Odoc_info.string_of_module_type t
+	   );
+	 p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n"
+	   (match m.mt_type with
+	     None -> "None"
+	   | Some t -> Odoc_info.string_of_module_type ~complete: true t
+	   );
+	);
+      true
+
+    method generate (module_list: Odoc_info.Module.t_module list) =
+      let oc = open_out !Odoc_info.Args.out_file in
+      fmt <- Format.formatter_of_out_channel oc;
+      (
+       try
+	 List.iter
+	   (fun m -> 
+	     self#set_test_kinds_from_module m;
+	     self#scan_module_list [m];
+	   )
+	   module_list
+       with
+	 e ->
+	   prerr_endline (Printexc.to_string e)
+      );
+      Format.pp_print_flush fmt ();
+      close_out oc
+  end
+
+
+let my_generator = new string_gen
+let _ = Odoc_info.Args.set_doc_generator 
+    (Some (my_generator :> Odoc_info.Args.doc_generator))
diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
index 3a52d104..df4b4837 100644
--- a/ocamldoc/odoc_texi.ml
+++ b/ocamldoc/odoc_texi.ml
@@ -1,14 +1,14 @@
 (***********************************************************************)
 (*                           OCamldoc                                  *)
 (*                                                                     *)
-(*      Olivier Andrieu, basé sur du code de Maxence Guesdon           *)
+(*      Olivier Andrieu, base sur du code de Maxence Guesdon           *)
 (*                                                                     *)
 (*  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: odoc_texi.ml,v 1.13 2003/09/05 15:40:12 guesdon Exp $ *)
+(* $Id: odoc_texi.ml,v 1.17.4.1 2004/07/02 12:59:48 guesdon Exp $ *)
 
 (** Generation of Texinfo documentation. *)
 
@@ -297,6 +297,8 @@ class text =
       | Ref (name, kind) ->self#texi_of_Ref name kind
       | Superscript t -> self#texi_of_Superscript t
       | Subscript t -> self#texi_of_Subscript t
+      |	Odoc_info.Module_list _ -> ""
+      |	Odoc_info.Index_list -> ""
 
     method texi_of_Verbatim s = s
     method texi_of_Raw s = self#escape s
@@ -370,7 +372,7 @@ class text =
 
   end
 
-
+exception Aliased_node
 
 (** This class is used to create objects which can generate a simple
     Texinfo documentation. *)
@@ -389,7 +391,15 @@ class texi =
 
     val mutable indices_to_build = [ `Module ]
 
+    (** Keep a set of nodes we create. If we try to create one
+        a second time, that means it is some kind of alias, so
+        don't do it, just link to the previous one *)
+    val node_tbl = Hashtbl.create 37
+
     method node depth name = 
+      if Hashtbl.mem node_tbl name
+      then raise Aliased_node ;
+      Hashtbl.add node_tbl name () ;
       if depth <= maxdepth 
       then Verbatim ("@node " ^ (Texi.fix_nodename name) ^ ",\n")
       else nothing
@@ -412,7 +422,8 @@ class texi =
           (function
             | Newline -> Raw "\n"
             | Raw s -> Raw (Str.global_replace re "\n" s)
-            | List tel | Enum tel -> List (List.map self#fix_linebreaks tel)
+            | List tel -> List (List.map self#fix_linebreaks tel)
+            | Enum tel -> Enum (List.map self#fix_linebreaks tel)
             | te -> te) t
 
     method private soft_fix_linebreaks = 
@@ -741,7 +752,7 @@ class texi =
     (** Return the Texinfo code for the given included module. *)
     method texi_of_included_module im =
       let t = [ self#fixedblock
-                  ( Newline :: minus :: (Raw "include module ") ::
+                  ( Newline :: minus :: (Raw "include ") ::
                     ( match im.im_module with
                     | None -> 
                         [ Raw im.im_name ]
@@ -751,7 +762,12 @@ class texi =
                     | Some (Modtype { mt_name = name }) ->
                         [ Raw name ; Raw "\n     " ; 
                           Ref (name, Some RK_module_type) ]
-                     ) ) ] in
+                    ) @ 
+		   [ Newline ] @
+		   (self#text_of_info im.im_info)
+		  ) 
+	      ] 
+      in
       self#texi_of_text t
 
     (** Return the Texinfo code for the given class. *)
@@ -856,6 +872,7 @@ class texi =
     (** Generate the Texinfo code for the given class, 
        in the given out channel. *)
     method generate_for_class chanout c =
+     try
       Odoc_info.reset_type_names () ;
       let depth = Name.depth c.cl_name in
       let title = [ 
@@ -881,11 +898,13 @@ class texi =
         (fun ele -> puts chanout
             (self#texi_of_class_element c.cl_name ele))
         (Class.class_elements ~trans:false c)
+     with Aliased_node -> ()
 
 
     (** Generate the Texinfo code for the given class type, 
        in the given out channel. *)
     method generate_for_class_type chanout ct =
+     try
       Odoc_info.reset_type_names () ;
       let depth = Name.depth ct.clt_name in
       let title = [ 
@@ -911,12 +930,13 @@ class texi =
         (fun ele -> puts chanout
             (self#texi_of_class_element ct.clt_name ele))
         (Class.class_type_elements ~trans:false ct)
-
+     with Aliased_node -> ()
 
 
     (** Generate the Texinfo code for the given module type, 
        in the given out channel. *)
     method generate_for_module_type chanout mt =
+     try
       let depth = Name.depth mt.mt_name in
       let title = [ 
         self#node depth mt.mt_name ;
@@ -959,11 +979,12 @@ class texi =
           | `Class c -> self#generate_for_class chanout c
           | `Class_type ct -> self#generate_for_class_type chanout ct)
         subparts
-
+     with Aliased_node -> ()
 
     (** Generate the Texinfo code for the given module, 
        in the given out channel. *)
     method generate_for_module chanout m =
+     try
       Odoc_info.verbose ("Generate for module " ^ m.m_name) ;
       let depth = Name.depth m.m_name in
       let title = [ 
@@ -1008,10 +1029,10 @@ class texi =
           | `Class c -> self#generate_for_class chanout c
           | `Class_type ct -> self#generate_for_class_type chanout ct )
         subparts
+     with Aliased_node -> ()
 
 
-
-    (** Writes the header of the TeX document. *)
+    (** Writes the header of the TeXinfo document. *)
     method generate_texi_header chan texi_filename m_list =
       let title = match !Args.title with
       | None -> ""
@@ -1063,14 +1084,22 @@ class texi =
                "@node Top, , , (dir)" ;
                "@top "^ title ; ]
            ] ) ;
-      if title <> ""
-      then begin
-        puts_nl chan "@ifinfo" ; 
-        puts_nl chan ("Documentation for " ^ title) ; 
-        puts_nl chan "@end ifinfo" 
-      end 
-      else puts_nl chan "@c no title given" ;
-      
+
+      (* insert the intro file *)
+      begin
+	match !Odoc_info.Args.intro_file with
+	| None when title <> "" ->
+            puts_nl chan "@ifinfo" ; 
+            puts_nl chan ("Documentation for " ^ title) ; 
+            puts_nl chan "@end ifinfo"
+	| None ->
+	    puts_nl chan "@c no title given"
+	| Some f ->
+	    nl chan ;
+	    puts_nl chan
+	      (self#texi_of_info (Some (Odoc_info.info_of_comment_file f)))
+      end ;
+
       (* write a top menu *)
       Texi.generate_menu chan 
         ((List.map (fun m -> `Module m) m_list) @
@@ -1088,7 +1117,7 @@ class texi =
          else [] ))
       
 
-    (** Writes the header of the TeX document. *)
+    (** Writes the trailer of the TeXinfo document. *)
     method generate_texi_trailer chan = 
       nl chan ; 
       if !Args.with_index
@@ -1129,7 +1158,7 @@ class texi =
 	  List.iter self#scan_for_index_in_class c_ele
 	    
     method scan_for_index_in_mod = function
-	(* no recusrion *)
+	(* no recursion *)
       | Element_value _ -> self#do_index `Value
       | Element_exception _ -> self#do_index `Exception
       | Element_type _ -> self#do_index `Type
@@ -1154,6 +1183,7 @@ class texi =
     (** Generate the Texinfo file from a module list, 
        in the {!Odoc_info.Args.out_file} file. *)
     method generate module_list =
+      Hashtbl.clear node_tbl ;
       let filename = 
 	if !Args.out_file = Odoc_messages.default_out_file
 	then "ocamldoc.texi"
diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml
index 5a9b9130..9b6652c5 100644
--- a/ocamldoc/odoc_text.ml
+++ b/ocamldoc/odoc_text.ml
@@ -9,9 +9,12 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_text.ml,v 1.5 2004/05/23 10:41:50 guesdon Exp $ *)
 
 exception Text_syntax of int * int * string (* line, char, string *)
 
+open Odoc_types
+
 module Texter =
   struct
     (* builds a text structure from a string. *)
@@ -26,5 +29,122 @@ module Texter =
                               !Odoc_text_lexer.char_number, 
                               s)
                 )
+
+    let count s c =
+      let count = ref 0 in
+      for i = 0 to String.length s - 1 do
+	if s.[i] = c then incr count
+      done;
+      !count
+
+    let escape_n s c n =
+      let remain = ref n in
+      let len = String.length s in
+      let b = Buffer.create (len + n) in
+      for i = 0 to len - 1 do
+	if s.[i] = c && !remain > 0 then
+	  (
+	   Printf.bprintf b "\\%c" c;
+	   decr remain
+	  )
+	else
+	  Buffer.add_char b s.[i]
+      done;
+      Buffer.contents b
+
+    let escape_code s =
+      let open_brackets = count s '[' in
+      let close_brackets = count s ']' in
+      if open_brackets > close_brackets then
+	escape_n s '[' (open_brackets - close_brackets)
+      else
+	if close_brackets > open_brackets then
+	  escape_n s ']' (close_brackets - open_brackets) 
+	else
+	  s
+
+    let escape_raw s =
+      let len = String.length s in
+      let b = Buffer.create len in
+      for i = 0 to len - 1 do
+	match s.[i] with
+	  '[' | ']' | '{' | '}' ->
+	    Printf.bprintf b "\\%c" s.[i]
+	| c ->
+	    Buffer.add_char b c
+      done;
+      Buffer.contents b
+
+    let p = Printf.bprintf
+
+    let rec p_text b t =
+      List.iter (p_text_element b) t
+
+    and p_list b l =
+      List.iter
+	(fun t -> p b "{- " ; p_text b t ; p b "}\n")
+	l
+
+    and p_text_element b = function
+      | Raw s -> p b "%s" (escape_raw s)
+      | Code s -> p b "[%s]" (escape_code s)
+      | CodePre s -> p b "{[%s]}" s
+      | Verbatim s -> p b "{v %s v}" s
+      | Bold t -> p b "{b " ; p_text b t ; p b "}"
+      | Italic t -> p b "{i " ; p_text b t ; p b "}"
+      | Emphasize t -> p b "{e " ; p_text b t ; p b "}"
+      | Center t -> p b "{C " ; p_text b t ; p b "}"
+      | Left t -> p b "{L " ; p_text b t ; p b "}"
+      | Right t -> p b "{R " ; p_text b t ; p b "}"
+      | List l -> p b "{ul\n"; p_list b l; p b "}"
+      | Enum l -> p b "{ol\n"; p_list b l; p b "}"
+      | Newline -> p b "\n" 
+      | Block  t -> p_text b t
+      | Title (n, l_opt, t) ->
+	  p b "{%d%s " 
+	    n
+	    (match l_opt with
+	      None -> ""
+	    | Some s -> ":"^s
+	    );
+	  p_text b t ; 
+	  p b "}"
+      | Latex s -> p b "{%% %s%%}" s
+      | Link (s,t) ->
+	  p b "{{:%s}" s;
+	  p_text b t ;
+	  p b "}"
+      | Ref (s,None) ->
+	  p b "{!%s}" s
+      |	Ref (s, Some k) ->
+	  (
+	   let sk = match k with
+	     RK_module -> "module"
+	   | RK_module_type -> "modtype"
+	   | RK_class -> "class"
+	   | RK_class_type -> "classtype"
+	   | RK_value -> "val"
+	   | RK_type -> "type"
+	   | RK_exception -> "exception"
+	   | RK_attribute -> "attribute"
+	   | RK_method -> "method"
+	   | RK_section _ -> "section"
+	   in
+	   p b "{!%s:%s}" sk s	   
+	  )
+      | Superscript t -> p b "{^" ; p_text b t ; p b "}"
+      | Subscript t -> p b "{_" ; p_text b t ; p b "}"
+      | Module_list l -> 
+	  p b "{!modules:";
+	  List.iter (fun s -> p b " %s" s) l;
+	  p b "}"
+      |	Index_list ->
+	  p b "{!indexlist}"
+	    
+    let string_of_text s =
+      let b = Buffer.create 256 in
+      p_text b s;
+      Buffer.contents b
+	
   end
  
diff --git a/ocamldoc/odoc_text.mli b/ocamldoc/odoc_text.mli
index 5b18a413..6dca491a 100644
--- a/ocamldoc/odoc_text.mli
+++ b/ocamldoc/odoc_text.mli
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_text.mli,v 1.3 2003/11/24 21:20:51 guesdon Exp $ *)
 
 (** A module with a function to parse strings to obtain a [Odoc_types.text] value. *)
 
@@ -17,4 +18,7 @@ exception Text_syntax of int * int * string (* line, char, string *)
 
 (** Transformation of strings to text structures. *)
 module Texter : 
-    sig val text_of_string : string -> Odoc_types.text end
+    sig 
+      val text_of_string : string -> Odoc_types.text 
+      val string_of_text : Odoc_types.text -> string
+    end
diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll
index b141c914..5c84748e 100644
--- a/ocamldoc/odoc_text_lexer.mll
+++ b/ocamldoc/odoc_text_lexer.mll
@@ -10,6 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_text_lexer.mll,v 1.8 2004/05/23 10:41:50 guesdon Exp $ *)
+
 (** The lexer for string to build text structures. *)
 
 open Lexing
@@ -158,8 +160,8 @@ let begin_clt_ref = "{!classtype:"blank_nl | "{!classtype:"
 let begin_att_ref = "{!attribute:"blank_nl | "{!attribute:"
 let begin_met_ref = "{!method:"blank_nl | "{!method:"
 let begin_sec_ref = "{!section:"blank_nl | "{!section:"
-
-
+let begin_mod_list_ref = "{!modules:"blank_nl | "{!modules:"
+let index_list = "{!indexlist}"
 let begin_superscript = "{^"blank_nl | "{^"
 let begin_subscript = "{_"blank_nl | "{_"
 
@@ -416,13 +418,33 @@ rule main = parse
       if !verb_mode or !latex_mode or !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
-        if !code_pre_mode then 
-          (
-           code_pre_mode := false;
-           END_CODE_PRE 
-          )
-        else
-          Char (Lexing.lexeme lexbuf)
+	if !open_brackets >= 1 then
+	  (
+	   lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
+           lexbuf.Lexing.lex_curr_p <- 
+	     { lexbuf.Lexing.lex_curr_p with
+	       pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1
+	     } ;
+	   decr char_number ;
+	   if !open_brackets > 1 then
+	     (
+	      decr open_brackets;
+              Char "]"
+	     )
+	   else
+	     (
+              open_brackets := 0;
+              END_CODE 
+             )
+	  )
+	else
+          if !code_pre_mode then 
+            (
+             code_pre_mode := false;
+             END_CODE_PRE 
+            )
+          else
+            Char (Lexing.lexeme lexbuf)
     }
 
 | begin_ele_ref end
@@ -619,6 +641,34 @@ rule main = parse
           )
     }
 
+| begin_mod_list_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           MOD_LIST_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+
+| index_list
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode or !latex_mode or !code_pre_mode or !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+	if not !ele_ref_mode then
+          INDEX_LIST
+	else
+	  Char (Lexing.lexeme lexbuf)
+    } 
 
 | begin_verb    
     {
@@ -686,7 +736,10 @@ rule main = parse
          END_SHORTCUT_LIST
         )
       else
-        BLANK_LINE
+	if !latex_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode or !verb_mode then
+	  Char (Lexing.lexeme lexbuf)
+	else
+          BLANK_LINE
     } 
    
 | eof           { EOF }
diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly
index ab399510..44d947f4 100644
--- a/ocamldoc/odoc_text_parser.mly
+++ b/ocamldoc/odoc_text_parser.mly
@@ -10,6 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_text_parser.mly,v 1.4 2004/05/23 10:41:50 guesdon Exp $ *)
+
 open Odoc_types
 
 let identchar = 
@@ -58,7 +60,8 @@ let print_DEBUG s = print_string s; print_newline ()
 %token ATT_REF
 %token MET_REF
 %token SEC_REF
-
+%token MOD_LIST_REF
+%token INDEX_LIST
 
 %token SUPERSCRIPT
 %token SUBSCRIPT
@@ -162,6 +165,13 @@ text_element:
       let s3 = remove_trailing_blanks s2 in
       Ref (s3, Some (RK_section []))
      }
+| MOD_LIST_REF string END { 
+      let s2 = remove_beginning_blanks $2 in
+      let s3 = remove_trailing_blanks s2 in
+      let l = Odoc_misc.split_with_blanks s3 in
+      Module_list l
+     }
+| INDEX_LIST { Index_list } 
 | VERB string END_VERB { Verbatim $2 }
 | LATEX string END_LATEX { Latex $2 }
 | LINK string END text END { Link ($2, $4) }
diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml
index 7b325bd3..1e7fcc77 100644
--- a/ocamldoc/odoc_to_text.ml
+++ b/ocamldoc/odoc_to_text.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_to_text.ml,v 1.14.4.1 2004/07/09 10:42:10 guesdon Exp $ *)
 
 (** Text generation.
 
@@ -187,21 +188,42 @@ class virtual to_text =
       in
       s2
 
+    (** Take a string and return the string where fully qualified idents 
+       have been replaced by idents relative to the given module name.
+       Also remove the "hidden modules".*)
+    method relative_module_idents m_name s =
+      let f str_t = 
+        let match_s = Str.matched_string str_t in
+        let rel = Name.get_relative m_name match_s in
+        Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel
+      in
+      let s2 = Str.global_substitute
+          (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)")
+          f
+          s
+      in
+      s2
+
     (** Get a string for a [Types.class_type] where all idents are relative. *)
     method normal_class_type m_name t =
       (self#relative_idents m_name (Odoc_info.string_of_class_type t))
 
     (** Get a string for a [Types.module_type] where all idents are relative. *)
-    method normal_module_type m_name t =
-      (self#relative_idents m_name (Odoc_info.string_of_module_type t))
+    method normal_module_type ?code m_name t =
+      (self#relative_module_idents m_name (Odoc_info.string_of_module_type ?code t))
 
     (** Get a string for a type where all idents are relative. *)
     method normal_type m_name t =
       (self#relative_idents m_name (Odoc_info.string_of_type_expr t))
 
     (** Get a string for a list of types where all idents are relative. *)
-    method normal_type_list m_name sep t =
-      (self#relative_idents m_name (Odoc_info.string_of_type_list sep t))
+    method normal_type_list ?par m_name sep t =
+      (self#relative_idents m_name (Odoc_info.string_of_type_list ?par sep t))
+
+    (** Get a string for a list of class or class type type parameters
+       where all idents are relative. *)
+    method normal_class_type_param_list m_name t =
+      (self#relative_idents m_name (Odoc_info.string_of_class_type_param_list t))
 
     (** @return [text] value to represent a [Types.type_expr].*)
     method text_of_type_expr module_name t =
@@ -223,6 +245,11 @@ class virtual to_text =
     method text_of_type_expr_list module_name sep l =
       [ Code (self#normal_type_list module_name sep l) ]        
 
+    (** Return [text] value or the given list of [Types.type_expr], 
+       as type parameters of a class of class type. *)
+    method text_of_class_type_param_expr_list module_name l =
+      [ Code (self#normal_class_type_param_list module_name l) ]        
+
 
     (** @return [text] value to represent a [Types.module_type]. *)
     method text_of_module_type t =
@@ -233,7 +260,8 @@ class virtual to_text =
     
     (** @return [text] value for a value. *)
     method text_of_value v =
-      let s_name = Name.simple v.val_name in
+      let name = v.val_name in
+      let s_name = Name.simple name in
       let s = 
 	Format.fprintf Format.str_formatter "@[<hov 2>val %s :@ %s"
           s_name
@@ -285,7 +313,9 @@ class virtual to_text =
         | _ -> 
             Format.fprintf Format.str_formatter "@ of "
         );
-      let s = self#normal_type_list (Name.father e.ex_name) " * " e.ex_args in
+      let s = self#normal_type_list 
+	  ~par: false (Name.father e.ex_name) " * " e.ex_args 
+      in
       let s2 = 
         Format.fprintf Format.str_formatter "%s" s ;
         (match e.ex_alias with
@@ -437,7 +467,7 @@ class virtual to_text =
              [] -> []
            | l -> 
                (Code "[") ::
-               (self#text_of_type_expr_list father  ", " l) @
+               (self#text_of_class_type_param_expr_list father l) @
                [Code "] "]
           ) @
           (
@@ -489,25 +519,24 @@ class virtual to_text =
           [Code ((if with_def_syntax then " : " else "")^
                  Odoc_messages.struct_end^" ")]
 
-      | Module_functor (_, k)  ->
+      | Module_functor (p, k)  ->
           (if with_def_syntax then [Code " : "] else []) @
           [Code "functor ... "] @
           [Code " -> "] @
           (self#text_of_module_kind ~with_def_syntax: false k)
 
-    (** Return html code for a [module_type_kind]. *)
+    (** Return html code for a [module_type_kind].*)
     method text_of_module_type_kind ?(with_def_syntax=true) tk =
       match tk with
       | Module_type_struct _ ->
           [Code ((if with_def_syntax then " = " else "")^Odoc_messages.sig_end)]
 
-      | Module_type_functor (params, k) ->
-          let f p = 
-            [Code ("("^p.mp_name^" : ")] @ 
-            (self#text_of_module_type p.mp_type) @
+      | Module_type_functor (p, k) ->
+          let t1 =
+	    [Code ("("^p.mp_name^" : ")] @ 
+            (self#text_of_module_type_kind p.mp_kind) @
             [Code ") -> "]
           in
-          let t1 = List.flatten (List.map f params) in
           let t2 = self#text_of_module_type_kind ~with_def_syntax: false k in
           (if with_def_syntax then [Code " = "] else []) @ t1 @ t2
           
@@ -523,4 +552,5 @@ class virtual to_text =
                  | Some mt -> mt.mt_name))
           ] 
 
+
   end
diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml
index 946b70eb..fdbbeac9 100644
--- a/ocamldoc/odoc_type.ml
+++ b/ocamldoc/odoc_type.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_type.ml,v 1.5 2003/11/24 10:44:07 starynke Exp $ *)
 
 (** Representation and manipulation of a type, but not class nor module type.*)
 
diff --git a/ocamldoc/odoc_types.ml b/ocamldoc/odoc_types.ml
index 86367be9..c4709136 100644
--- a/ocamldoc/odoc_types.ml
+++ b/ocamldoc/odoc_types.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_types.ml,v 1.7 2004/05/23 10:41:51 guesdon Exp $ *)
 
 type ref_kind = 
     RK_module
@@ -43,6 +44,8 @@ and text_element =
   | Ref of string * ref_kind option
   | Superscript of text
   | Subscript of text
+  | Module_list of string list
+  | Index_list
 
 and text = text_element list
 
diff --git a/ocamldoc/odoc_types.mli b/ocamldoc/odoc_types.mli
index 42c80f5d..4e604710 100644
--- a/ocamldoc/odoc_types.mli
+++ b/ocamldoc/odoc_types.mli
@@ -9,6 +9,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_types.mli,v 1.5 2004/05/23 10:41:51 guesdon Exp $ *)
+
 (** Types for the information collected in comments. *)
 
 (** The differents kinds of element references. *)
@@ -47,6 +49,9 @@ and text_element =
        (** A reference to an element. Complete name and kind. *)
   | Superscript of text (** Superscripts. *)
   | Subscript of text (** Subscripts. *)
+  | Module_list of string list 
+       (** The table of the given modules with their abstract; *)
+  | Index_list (** The links to the various indexes (values, types, ...) *)
 
 (** [text] is a list of text_elements. The order matters. *)
 and text = text_element list
diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml
index b5b8eb0d..78af4440 100644
--- a/ocamldoc/odoc_value.ml
+++ b/ocamldoc/odoc_value.ml
@@ -9,6 +9,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: odoc_value.ml,v 1.5.6.1 2004/07/02 12:59:49 guesdon Exp $ *)
 
 (** Representation and manipulation of values, class attributes and class methods. *)
 
@@ -71,7 +72,18 @@ let parameter_list_from_arrows typ =
     match t.Types.desc with
       Types.Tarrow (l, t1, t2, _) ->
         (l, t1) :: (iter t2)
-    | _ ->
+    | Types.Tlink texp 
+    | Types.Tsubst texp ->
+	iter texp
+    | Types.Tpoly (texp, _) -> iter texp
+    | Types.Tvar
+    | Types.Ttuple _ 
+    | Types.Tconstr _ 
+    | Types.Tobject _
+    | Types.Tfield _ 
+    | Types.Tnil
+    | Types.Tunivar
+    | Types.Tvariant _ ->
         []
   in
   iter typ
diff --git a/ocamldoc/remove_DEBUG b/ocamldoc/remove_DEBUG
index 99ab8972..da94ce04 100755
--- a/ocamldoc/remove_DEBUG
+++ b/ocamldoc/remove_DEBUG
@@ -1,8 +1,21 @@
 #!/bin/sh
 
+#(***********************************************************************)
+#(*                            OCamldoc                                 *)
+#(*                                                                     *)
+#(*            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: remove_DEBUG,v 1.3 2004/04/15 16:18:52 doligez Exp $
+
 # usage: remove_DEBUG <file>
 # remove from <file> every line that contains the string "DEBUG",
 # respecting the cpp # line annotation conventions
 
 echo "# 1 \"$1\""
-sed -e '/DEBUG/s/.*//' "$1"
+LC_ALL=C sed -e '/DEBUG/s/.*//' "$1"
diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend
index 7c4e124e..8ce87779 100644
--- a/otherlibs/bigarray/.depend
+++ b/otherlibs/bigarray/.depend
@@ -1,17 +1,19 @@
 bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \
-  ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/mlvalues.h bigarray.h \
+  ../../byterun/compatibility.h ../../byterun/misc.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/mlvalues.h bigarray.h ../../byterun/compare.h \
   ../../byterun/custom.h ../../byterun/fail.h ../../byterun/intext.h \
   ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/memory.h \
   ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h
 mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/mlvalues.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/custom.h ../../byterun/fail.h \
-  ../../byterun/sys.h
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/custom.h \
+  ../../byterun/fail.h ../../byterun/sys.h
 mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/mlvalues.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/custom.h \
-  ../../byterun/fail.h ../../byterun/sys.h ../unix/unixsupport.h
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/custom.h ../../byterun/fail.h ../../byterun/sys.h \
+  ../unix/unixsupport.h
 bigarray.cmo: bigarray.cmi 
 bigarray.cmx: bigarray.cmi 
diff --git a/otherlibs/bigarray/Makefile.Mac b/otherlibs/bigarray/Makefile.Mac
deleted file mode 100644
index 089e21db..00000000
--- a/otherlibs/bigarray/Makefile.Mac
+++ /dev/null
@@ -1,53 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#          Damien Doligez, projet Moscova, INRIA Rocquencourt           #
-#                                                                       #
-#   Copyright 2000 Institut National de Recherche en Informatique et    #
-#   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the GNU Library General Public License, with     #
-#   the special exception on linking described in file ../../LICENSE.   #
-#                                                                       #
-#########################################################################
-
-# $Id: Makefile.Mac,v 1.4 2001/12/07 13:39:49 xleroy Exp $
-
-PPCC = mrc
-PPCCOptions = -i :::byterun:,:::config: -w 35 {cdbgflag}
-
-CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib: -I ::unix:
-
-PPCC_OBJS = bigarray_stubs.c.x mmap_unix.c.x
-
-CAML_OBJS = bigarray.cmo
-
-all Ä libbigarray.x bigarray.cma
-
-libbigarray.x Ä {PPCC_OBJS}
-    ppclink {ldbgflag} -xm library -o libbigarray.x {PPCC_OBJS}
-
-bigarray.cma Ä {CAML_OBJS}
-    {CAMLC} -a -linkall -o bigarray.cma {CAML_OBJS}
-
-install Ä
-    duplicate -y bigarray.cmi bigarray.mli libbigarray.x ¶
-              bigarray.cma "{LIBDIR}"
-
-partialclean Ä
-    delete -y Å.cmÅ || set status 0
-
-clean Ä partialclean
-    delete -i Å.x || set status 0
-
-.cmi Ä .mli
-    {CAMLC} -c {COMPFLAGS} {depdir}{default}.mli
-
-.cmo Ä .ml
-    {CAMLC} -c {COMPFLAGS} {depdir}{default}.ml
-
-depend Ä
-    begin
-      MakeDepend -w -objext .x Å.c
-      :::boot:ocamlrun :::tools:ocamldep -I :::stdlib: -I ::unix: Å.mli Å.ml
-    end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/otherlibs/bigarray/Makefile.Mac.depend b/otherlibs/bigarray/Makefile.Mac.depend
deleted file mode 100644
index b2608cbe..00000000
--- a/otherlibs/bigarray/Makefile.Mac.depend
+++ /dev/null
@@ -1,42 +0,0 @@
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 20:33:17 on Tue, Aug 21, 2001 by MakeDepend
-
-:bigarray_stubs.c.x Ä  ¶
- :bigarray_stubs.c ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"stdarg.h ¶
- "{CIncludes}"string.h ¶
- :bigarray.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"VaListTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:mmap_unix.c.x Ä  ¶
- :mmap_unix.c ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"string.h ¶
- :bigarray.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"WCharTDef.h
-
-:mmap_win32.c.x Ä  ¶
- :mmap_win32.c ¶
- "{CIncludes}"stddef.h ¶
- "{CIncludes}"string.h ¶
- :bigarray.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"WCharTDef.h
-
-bigarray.cmiÄ ::unix:unix.cmi 
-bigarray.cmoÄ :::stdlib:array.cmi :::stdlib:obj.cmi ::unix:unix.cmi ¶
-    bigarray.cmi 
-bigarray.cmxÄ :::stdlib:array.cmx :::stdlib:obj.cmx ::unix:unix.cmx ¶
-    bigarray.cmi 
diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c
index 86a5b245..c2a68f5e 100644
--- a/otherlibs/bigarray/bigarray_stubs.c
+++ b/otherlibs/bigarray/bigarray_stubs.c
@@ -11,13 +11,14 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bigarray_stubs.c,v 1.17 2003/07/08 14:07:35 xleroy Exp $ */
+/* $Id: bigarray_stubs.c,v 1.19 2003/12/15 18:10:50 doligez Exp $ */
 
 #include <stddef.h>
 #include <stdarg.h>
 #include <string.h>
 #include "alloc.h"
 #include "bigarray.h"
+#include "compare.h"
 #include "custom.h"
 #include "fail.h"
 #include "intext.h"
@@ -73,6 +74,46 @@ static struct custom_operations bigarray_ops = {
   bigarray_deserialize
 };
 
+/* Multiplication of unsigned longs with overflow detection */
+
+static unsigned long
+bigarray_multov(unsigned long a, unsigned long b, int * overflow)
+{
+#define HALF_SIZE (sizeof(unsigned long) * 4)
+#define LOW_HALF(x) ((x) & ((1UL << HALF_SIZE) - 1))
+#define HIGH_HALF(x) ((x) >> HALF_SIZE)
+  /* Cut in half words */
+  unsigned long al = LOW_HALF(a);
+  unsigned long ah = HIGH_HALF(a);
+  unsigned long bl = LOW_HALF(b);
+  unsigned long bh = HIGH_HALF(b);
+  /* Exact product is:
+              al * bl
+           +  ah * bl  << HALF_SIZE
+           +  al * bh  << HALF_SIZE
+           +  ah * bh  << 2*HALF_SIZE
+     Overflow occurs if:
+        ah * bh is not 0, i.e. ah != 0 and bh != 0
+     OR ah * bl has high half != 0
+     OR ah * bl has high half != 0
+     OR the sum al * bl + LOW_HALF(ah * bl) << HALF_SIZE
+                        + LOW_HALF(al * bh) << HALF_SIZE overflows.
+     This sum is equal to p = (a * b) modulo word size. */
+  unsigned long p1 = al * bh;
+  unsigned long p2 = ah * bl;
+  unsigned long p = a * b;
+  if (ah != 0 && bh != 0) *overflow = 1;
+  if (p1 >= (1UL << HALF_SIZE) || p2 >= (1UL << HALF_SIZE)) *overflow = 1;
+  p1 <<= HALF_SIZE;
+  p2 <<= HALF_SIZE;
+  p1 += p2;
+  if (p < p1 || p1 < p2) *overflow = 1; /* overflow in sums */
+  return p;
+#undef HALF_SIZE
+#undef LOW_HALF
+#undef HIGH_HALF
+}
+
 /* Allocation of a big array */
 
 #define MAX_BIGARRAY_MEMORY 256*1024*1024
@@ -85,10 +126,11 @@ static struct custom_operations bigarray_ops = {
    [data] cannot point into the Caml heap.
    [dim] may point into an object in the Caml heap.
 */
-CAMLexport value alloc_bigarray(int flags, int num_dims, void * data, long * dim)
+CAMLexport value
+alloc_bigarray(int flags, int num_dims, void * data, long * dim)
 {
-  long num_elts, size;
-  int i;
+  unsigned long num_elts, size;
+  int overflow, i;
   value res;
   struct caml_bigarray * b;
   long dimcopy[MAX_NUM_DIMS];
@@ -98,9 +140,15 @@ CAMLexport value alloc_bigarray(int flags, int num_dims, void * data, long * dim
   for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i];
   size = 0;
   if (data == NULL) {
+    overflow = 0;
     num_elts = 1;
-    for (i = 0; i < num_dims; i++) num_elts = num_elts * dim[i];
-    size = num_elts * bigarray_element_size[flags & BIGARRAY_KIND_MASK];
+    for (i = 0; i < num_dims; i++) {
+      num_elts = bigarray_multov(num_elts, dimcopy[i], &overflow);
+    }
+    size = bigarray_multov(num_elts, 
+                           bigarray_element_size[flags & BIGARRAY_KIND_MASK],
+                           &overflow);
+    if (overflow) raise_out_of_memory();
     data = malloc(size);
     if (data == NULL && size != 0) raise_out_of_memory();
     flags |= BIGARRAY_MANAGED;
@@ -169,14 +217,14 @@ static long bigarray_offset(struct caml_bigarray * b, long * index)
     /* C-style layout: row major, indices start at 0 */
     for (i = 0; i < b->num_dims; i++) {
       if ((unsigned long) index[i] >= (unsigned long) b->dim[i])
-        invalid_argument("Bigarray: out-of-bound access");
+        array_bound_error();
       offset = offset * b->dim[i] + index[i];
     }
   } else {
     /* Fortran-style layout: column major, indices start at 1 */
     for (i = b->num_dims - 1; i >= 0; i--) {
       if ((unsigned long) (index[i] - 1) >= (unsigned long) b->dim[i])
-        invalid_argument("Bigarray: out-of-bound access");
+        array_bound_error();
       offset = offset * b->dim[i] + (index[i] - 1);
     }
   }
@@ -489,12 +537,26 @@ static int bigarray_compare(value v1, value v2)
   /* Same dimensions: compare contents lexicographically */
   num_elts = bigarray_num_elts(b1);
 
-#define DO_COMPARISON(type) \
+#define DO_INTEGER_COMPARISON(type) \
+  { type * p1 = b1->data; type * p2 = b2->data; \
+    for (n = 0; n < num_elts; n++) { \
+      type e1 = *p1++; type e2 = *p2++; \
+      if (e1 < e2) return -1; \
+      if (e1 > e2) return 1; \
+    } \
+    return 0; \
+  }
+#define DO_FLOAT_COMPARISON(type) \
   { type * p1 = b1->data; type * p2 = b2->data; \
     for (n = 0; n < num_elts; n++) { \
       type e1 = *p1++; type e2 = *p2++; \
       if (e1 < e2) return -1; \
       if (e1 > e2) return 1; \
+      if (e1 != e2) { \
+        compare_unordered = 1; \
+        if (e1 == e1) return 1; \
+        if (e2 == e2) return -1; \
+      } \
     } \
     return 0; \
   }
@@ -503,35 +565,45 @@ static int bigarray_compare(value v1, value v2)
   case BIGARRAY_COMPLEX32:
     num_elts *= 2; /*fallthrough*/
   case BIGARRAY_FLOAT32:
-    DO_COMPARISON(float);
+    DO_FLOAT_COMPARISON(float);
   case BIGARRAY_COMPLEX64:
     num_elts *= 2; /*fallthrough*/
   case BIGARRAY_FLOAT64:
-    DO_COMPARISON(double);
+    DO_FLOAT_COMPARISON(double);
   case BIGARRAY_SINT8:
-    DO_COMPARISON(schar);
+    DO_INTEGER_COMPARISON(schar);
   case BIGARRAY_UINT8:
-    DO_COMPARISON(unsigned char);
+    DO_INTEGER_COMPARISON(unsigned char);
   case BIGARRAY_SINT16:
-    DO_COMPARISON(int16);
+    DO_INTEGER_COMPARISON(int16);
   case BIGARRAY_UINT16:
-    DO_COMPARISON(uint16);
+    DO_INTEGER_COMPARISON(uint16);
   case BIGARRAY_INT32:
-    DO_COMPARISON(int32);
+    DO_INTEGER_COMPARISON(int32);
   case BIGARRAY_INT64:
 #ifdef ARCH_INT64_TYPE
-    DO_COMPARISON(int64);
+    DO_INTEGER_COMPARISON(int64);
 #else
-    invalid_argument("Bigarray.compare: 64-bit int arrays not supported");
+    { int64 * p1 = b1->data; int64 * p2 = b2->data;
+      for (n = 0; n < num_elts; n++) {
+        int64 e1 = *p1++; int64 e2 = *p2++;
+        if ((int32)e1.h > (int32)e2.h) return 1;
+        if ((int32)e1.h < (int32)e2.h) return -1;
+        if (e1.l > e2.l) return 1;
+        if (e1.l < e2.l) return -1;
+      }
+      return 0;
+    }
 #endif
   case BIGARRAY_CAML_INT:
   case BIGARRAY_NATIVE_INT:
-    DO_COMPARISON(long);
+    DO_INTEGER_COMPARISON(long);
   default:
     Assert(0);
     return 0;                   /* should not happen */
   }
-#undef DO_COMPARISON
+#undef DO_INTEGER_COMPARISON
+#undef DO_FLOAT_COMPARISON
 }
 
 /* Hashing of a bigarray */
diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
index 0bf5462f..c31291cd 100644
--- a/otherlibs/dynlink/Makefile
+++ b/otherlibs/dynlink/Makefile
@@ -11,7 +11,7 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile,v 1.26 2002/11/17 16:42:11 xleroy Exp $
+# $Id: Makefile,v 1.27 2004/02/22 15:07:51 xleroy Exp $
 
 # Makefile for the dynamic link library
 
@@ -25,7 +25,7 @@ OBJS=dynlink.cmo
 COMPILEROBJS=misc.cmo config.cmo tbl.cmo clflags.cmo consistbl.cmo \
   ident.cmo path.cmo \
   types.cmo btype.cmo predef.cmo runtimedef.cmo \
-  bytesections.cmo dll.cmo symtable.cmo opcodes.cmo meta.cmo
+  bytesections.cmo dll.cmo meta.cmo symtable.cmo opcodes.cmo
 
 all: dynlink.cma extract_crc
 
diff --git a/otherlibs/dynlink/Makefile.Mac b/otherlibs/dynlink/Makefile.Mac
deleted file mode 100644
index aac9a346..00000000
--- a/otherlibs/dynlink/Makefile.Mac
+++ /dev/null
@@ -1,56 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#            Damien Doligez, projet Para, INRIA Rocquencourt            #
-#                                                                       #
-#   Copyright 1999 Institut National de Recherche en Informatique et    #
-#   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the GNU Library General Public License, with     #
-#   the special exception on linking described in file ../../LICENSE.   #
-#                                                                       #
-#########################################################################
-
-# $Id: Makefile.Mac,v 1.13 2001/12/13 13:59:26 doligez Exp $
-
-# Makefile for the dynamic link library
-
-CAMLC = :::boot:ocamlrun :::ocamlc
-INCLUDES = -I :::utils: -I :::typing: -I :::bytecomp:
-COMPFLAGS = -I :::stdlib: {INCLUDES}
-
-OBJS = dynlink.cmo
-COMPILEROBJS = misc.cmo config.cmo tbl.cmo ¶
-  clflags.cmo ident.cmo path.cmo ¶
-  types.cmo btype.cmo predef.cmo runtimedef.cmo ¶
-  bytesections.cmo dll.cmo symtable.cmo opcodes.cmo meta.cmo
-
-all Ä dynlink.cma extract_crc
-
-allopt Ä
-
-dynlink.cma Ä {OBJS}
-    {CAMLC} {COMPFLAGS} -a -o dynlink.cma {COMPILEROBJS} {OBJS}
-
-extract_crc Ä dynlink.cma extract_crc.cmo
-    {CAMLC} {COMPFLAGS} -o extract_crc dynlink.cma extract_crc.cmo
-
-install Ä
-    duplicate -y dynlink.cmi dynlink.cma extract_crc "{LIBDIR}"
-
-installopt Ä
-
-partialclean Ä
-    delete -i extract_crc
-    delete -i Å.cm[aio] || set status 0
-
-clean Ä partialclean
-
-.cmi Ä .mli
-    {CAMLC} -c {COMPFLAGS} {default}.mli
-
-.cmo Ä .ml
-    {CAMLC} -c {COMPFLAGS} {default}.ml
-
-depend Ä
-    :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml > Makefile.Mac.depend
diff --git a/otherlibs/dynlink/Makefile.Mac.depend b/otherlibs/dynlink/Makefile.Mac.depend
deleted file mode 100644
index 6a7522b5..00000000
--- a/otherlibs/dynlink/Makefile.Mac.depend
+++ /dev/null
@@ -1,4 +0,0 @@
-dynlink.cmoÄ dynlink.cmi 
-dynlink.cmxÄ dynlink.cmi 
-extract_crc.cmoÄ dynlink.cmi 
-extract_crc.cmxÄ dynlink.cmx 
diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml
index c2bbb3b4..3a548b2c 100644
--- a/otherlibs/dynlink/extract_crc.ml
+++ b/otherlibs/dynlink/extract_crc.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: extract_crc.ml,v 1.9 2001/12/07 13:39:52 xleroy Exp $ *)
+(* $Id: extract_crc.ml,v 1.10 2004/04/09 13:26:41 xleroy Exp $ *)
 
 (* Print the digests of unit interfaces *)
 
@@ -33,7 +33,9 @@ let print_crc unit =
     prerr_endline unit;
     begin match exn with
       Sys_error msg -> prerr_endline msg
-    | Dynlink.Error _ -> prerr_endline "Ill formed .cmi file"
+    | Dynlink.Error(Dynlink.File_not_found name) ->
+        prerr_string "Cannot find file "; prerr_endline name
+    | Dynlink.Error _ -> prerr_endline "Ill-formed .cmi file"
     | _ -> raise exn
     end;
     exit 2
diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend
index 1bc2b881..3d8fa25a 100644
--- a/otherlibs/graph/.depend
+++ b/otherlibs/graph/.depend
@@ -1,47 +1,85 @@
-color.o: color.c libgraph.h ../../byterun/mlvalues.h \
+color.o: color.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h
-draw.o: draw.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h
-dump_img.o: dump_img.c libgraph.h ../../byterun/mlvalues.h \
+  ../../byterun/misc.h /usr/X11R6/include/X11/Xatom.h
+draw.o: draw.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h
+dump_img.o: dump_img.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h image.h ../../byterun/alloc.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h
-events.o: events.c libgraph.h ../../byterun/mlvalues.h \
+events.o: events.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/signals.h
-fill.o: fill.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h
-image.o: image.c libgraph.h ../../byterun/mlvalues.h \
+fill.o: fill.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h
+image.o: image.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h image.h ../../byterun/alloc.h \
   ../../byterun/custom.h
-make_img.o: make_img.c libgraph.h ../../byterun/mlvalues.h \
+make_img.o: make_img.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h image.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h
-open.o: open.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/callback.h ../../byterun/fail.h \
-  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h
-point_col.o: point_col.c libgraph.h ../../byterun/mlvalues.h \
+open.o: open.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/callback.h \
+  ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h
+point_col.o: point_col.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h
-sound.o: sound.c libgraph.h ../../byterun/mlvalues.h \
+sound.o: sound.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h
-subwindow.o: subwindow.c libgraph.h ../../byterun/mlvalues.h \
+subwindow.o: subwindow.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h
-text.o: text.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h
+text.o: text.c libgraph.h /usr/X11R6/include/X11/Xlib.h \
+  /usr/X11R6/include/X11/X.h /usr/X11R6/include/X11/Xfuncproto.h \
+  /usr/X11R6/include/X11/Xosdefs.h /usr/X11R6/include/X11/Xutil.h \
+  ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h
 graphics.cmo: graphics.cmi 
 graphics.cmx: graphics.cmi 
 graphicsX11.cmo: graphics.cmi graphicsX11.cmi 
diff --git a/otherlibs/graph/Makefile.Mac.depend b/otherlibs/graph/Makefile.Mac.depend
deleted file mode 100644
index 2877a11e..00000000
--- a/otherlibs/graph/Makefile.Mac.depend
+++ /dev/null
@@ -1,4 +0,0 @@
-graphics.cmoÄ graphics.cmi 
-graphics.cmxÄ graphics.cmi 
-graphicsX11.cmoÄ graphics.cmi graphicsX11.cmi 
-graphicsX11.cmxÄ graphics.cmx graphicsX11.cmi 
diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c
index a9286495..b24b44bb 100644
--- a/otherlibs/graph/color.c
+++ b/otherlibs/graph/color.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: color.c,v 1.16 2002/07/23 14:11:53 doligez Exp $ */
+/* $Id: color.c,v 1.18 2004/05/17 17:10:00 doligez Exp $ */
 
 #include "libgraph.h"
 #include <X11/Xatom.h>
@@ -34,18 +34,18 @@ static int num_overflows = 0;
 
 /* rgb -> pixel conversion *without* display connection */
 
-Bool direct_rgb = False;
-int red_l, red_r;
-int green_l, green_r;
-int blue_l, blue_r;
-unsigned long red_mask, green_mask, blue_mask;
+Bool caml_gr_direct_rgb = False;
+int caml_gr_red_l, caml_gr_red_r;
+int caml_gr_green_l, caml_gr_green_r;
+int caml_gr_blue_l, caml_gr_blue_r;
+unsigned long caml_gr_red_mask, caml_gr_green_mask, caml_gr_blue_mask;
 
 /* rgb -> pixel table */
-unsigned long red_vals[256];
-unsigned long green_vals[256];
-unsigned long blue_vals[256];
+unsigned long caml_gr_red_vals[256];
+unsigned long caml_gr_green_vals[256];
+unsigned long caml_gr_blue_vals[256];
 
-void get_shifts( unsigned long mask, int *lsl, int *lsr )
+void caml_gr_get_shifts( unsigned long mask, int *lsl, int *lsr )
 {
   int l = 0;
   int r = 0;
@@ -66,98 +66,96 @@ void get_shifts( unsigned long mask, int *lsl, int *lsr )
   *lsr = 16 - (r - l);
 }
 
-void gr_init_direct_rgb_to_pixel(void)
+void caml_gr_init_direct_rgb_to_pixel(void)
 {
   Visual *visual;
   int i;
  
-  visual = DefaultVisual(grdisplay,grscreen);
+  visual = DefaultVisual(caml_gr_display,caml_gr_screen);
   
   if ( visual->class == TrueColor || visual->class == DirectColor ){
-    int lsl, lsr;
 
-    red_mask = visual->red_mask;
-    green_mask = visual->green_mask;
-    blue_mask = visual->blue_mask;
+    caml_gr_red_mask = visual->red_mask;
+    caml_gr_green_mask = visual->green_mask;
+    caml_gr_blue_mask = visual->blue_mask;
  
 #ifdef QUICKCOLORDEBUG
     fprintf(stderr, "visual %lx %lx %lx\n", 
-            red_mask, 
-            green_mask, 
-            blue_mask);
+            caml_gr_red_mask, 
+            caml_gr_green_mask, 
+            caml_gr_blue_mask);
 #endif
 
-    get_shifts(red_mask, &red_l, &red_r); 
+    caml_gr_get_shifts(caml_gr_red_mask, &caml_gr_red_l, &caml_gr_red_r); 
 #ifdef QUICKCOLORDEBUG
-    fprintf(stderr, "red %d %d\n", red_l, red_r);
+    fprintf(stderr, "red %d %d\n", caml_gr_red_l, caml_gr_red_r);
 #endif
     for(i=0; i<256; i++){
-      red_vals[i] = (((i << 8) + i) >> red_r) << red_l;
+      caml_gr_red_vals[i] = (((i << 8) + i) >> caml_gr_red_r) << caml_gr_red_l;
     }
 
-    get_shifts(green_mask, &green_l, &green_r); 
+    caml_gr_get_shifts(caml_gr_green_mask, &caml_gr_green_l, &caml_gr_green_r); 
 #ifdef QUICKCOLORDEBUG
-    fprintf(stderr, "green %d %d\n", green_l, green_r);
+    fprintf(stderr, "green %d %d\n", caml_gr_green_l, caml_gr_green_r);
 #endif
     for(i=0; i<256; i++){
-      green_vals[i] = (((i << 8) + i) >> green_r) << green_l;
+      caml_gr_green_vals[i] = (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l;
     }
 
-    get_shifts(blue_mask, &blue_l, &blue_r); 
+    caml_gr_get_shifts(caml_gr_blue_mask, &caml_gr_blue_l, &caml_gr_blue_r); 
 #ifdef QUICKCOLORDEBUG
-    fprintf(stderr, "blue %d %d\n", blue_l, blue_r);
+    fprintf(stderr, "blue %d %d\n", caml_gr_blue_l, caml_gr_blue_r);
 #endif
     for(i=0; i<256; i++){
-      blue_vals[i] = (((i << 8) + i) >> blue_r) << blue_l;
+      caml_gr_blue_vals[i] = (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l;
     }
     
-    if( red_l < 0 || red_r < 0 || 
-        green_l < 0 || green_r < 0 || 
-        blue_l < 0 || blue_r < 0 ){
+    if( caml_gr_red_l < 0 || caml_gr_red_r < 0 || 
+        caml_gr_green_l < 0 || caml_gr_green_r < 0 || 
+        caml_gr_blue_l < 0 || caml_gr_blue_r < 0 ){
 #ifdef QUICKCOLORDEBUG
       fprintf(stderr, "Damn, boost failed\n");
 #endif
-      direct_rgb = False;
+      caml_gr_direct_rgb = False;
     } else {
 #ifdef QUICKCOLORDEBUG
       fprintf(stderr, "Boost ok\n");
 #endif
-      direct_rgb = True;
+      caml_gr_direct_rgb = True;
     }
   } else {
     /* we cannot use direct_rgb_to_pixel */
 #ifdef QUICKCOLORDEBUG
     fprintf(stderr, "No boost!\n");
 #endif
-    direct_rgb = False;
+    caml_gr_direct_rgb = False;
   }
 }
 
-void gr_init_color_cache(void)
+void caml_gr_init_color_cache(void)
 {
   int i;
   for (i = 0; i < Color_cache_size; i++) color_cache[i].rgb = Empty;
   i = Hash_rgb(0, 0, 0);
   color_cache[i].rgb = 0;
-  color_cache[i].pixel = grblack;
+  color_cache[i].pixel = caml_gr_black;
   i = Hash_rgb(0xFF, 0xFF, 0xFF);
   color_cache[i].rgb = 0xFFFFFF;
-  color_cache[i].pixel = grwhite;
+  color_cache[i].pixel = caml_gr_white;
 }
 
-unsigned long gr_pixel_rgb(int rgb)
+unsigned long caml_gr_pixel_rgb(int rgb)
 {
   unsigned int r, g, b;
   int h, i;
   XColor color;
-  unsigned short tmp;
 
   r = (rgb >> 16) & 0xFF;
   g = (rgb >> 8) & 0xFF;
   b = rgb & 0xFF;
 
-  if (direct_rgb){
-    return red_vals[r] | green_vals[g] | blue_vals[b];
+  if (caml_gr_direct_rgb){
+    return caml_gr_red_vals[r] | caml_gr_green_vals[g] | caml_gr_blue_vals[b];
   }
 
   h = Hash_rgb(r, g, b);
@@ -179,28 +177,28 @@ unsigned long gr_pixel_rgb(int rgb)
   color.red = r * 0x101;
   color.green = g * 0x101;
   color.blue = b * 0x101;
-  XAllocColor(grdisplay, grcolormap, &color);
+  XAllocColor(caml_gr_display, caml_gr_colormap, &color);
   color_cache[i].rgb = rgb;
   color_cache[i].pixel = color.pixel;
   return color.pixel;
 }
 
-int gr_rgb_pixel(long unsigned int pixel)
+int caml_gr_rgb_pixel(long unsigned int pixel)
 {
   register int r,g,b;
  
   XColor color;
   int i;
 
-  if (direct_rgb) {
-    r = (((pixel & red_mask) >> red_l) << 8) >> (16 - red_r);
-    g = (((pixel & green_mask) >> green_l) << 8) >> (16 - green_r);
-    b = (((pixel & blue_mask) >> blue_l) << 8) >> (16 - blue_r);
+  if (caml_gr_direct_rgb) {
+    r = (((pixel & caml_gr_red_mask) >> caml_gr_red_l) << 8) >> (16 - caml_gr_red_r);
+    g = (((pixel & caml_gr_green_mask) >> caml_gr_green_l) << 8) >> (16 - caml_gr_green_r);
+    b = (((pixel & caml_gr_blue_mask) >> caml_gr_blue_l) << 8) >> (16 - caml_gr_blue_r);
     return (r << 16) + (g << 8) + b;
   }
 
-  if (pixel == grblack) return 0;
-  if (pixel == grwhite) return 0xFFFFFF;
+  if (pixel == caml_gr_black) return 0;
+  if (pixel == caml_gr_white) return 0xFFFFFF;
 
   /* Probably faster to do a linear search than to query the X server. */
   for (i = 0; i < Color_cache_size; i++) {
@@ -208,23 +206,23 @@ int gr_rgb_pixel(long unsigned int pixel)
       return color_cache[i].rgb;
   }
   color.pixel = pixel;
-  XQueryColor(grdisplay, grcolormap, &color);
+  XQueryColor(caml_gr_display, caml_gr_colormap, &color);
   return
     ((color.red >> 8) << 16) + ((color.green >> 8) << 8) + (color.blue >> 8);
 }
 
-value gr_set_color(value vrgb)
+value caml_gr_set_color(value vrgb)
 {
   int xcolor;
-  gr_check_open();
-  grcolor = Int_val(vrgb);
-  if (grcolor >= 0 ){
-    xcolor = gr_pixel_rgb(Int_val(vrgb));
-    XSetForeground(grdisplay, grwindow.gc, xcolor);
-    XSetForeground(grdisplay, grbstore.gc, xcolor);
+  caml_gr_check_open();
+  caml_gr_color = Int_val(vrgb);
+  if (caml_gr_color >= 0 ){
+    xcolor = caml_gr_pixel_rgb(Int_val(vrgb));
+    XSetForeground(caml_gr_display, caml_gr_window.gc, xcolor);
+    XSetForeground(caml_gr_display, caml_gr_bstore.gc, xcolor);
   } else {
-    XSetForeground(grdisplay, grwindow.gc, grbackground);
-    XSetForeground(grdisplay, grbstore.gc, grbackground);
+    XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_background);
+    XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background);
   }
   return Val_unit;
 }
diff --git a/otherlibs/graph/draw.c b/otherlibs/graph/draw.c
index f85e87f4..6c52a279 100644
--- a/otherlibs/graph/draw.c
+++ b/otherlibs/graph/draw.c
@@ -11,88 +11,80 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: draw.c,v 1.17 2003/04/25 12:25:07 xleroy Exp $ */
+/* $Id: draw.c,v 1.19 2004/05/30 14:11:41 xleroy Exp $ */
 
 #include "libgraph.h"
 #include <alloc.h>
 
-value gr_plot(value vx, value vy)
+value caml_gr_plot(value vx, value vy)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
-  gr_check_open();
-  if(grremember_mode)
-    XDrawPoint(grdisplay, grbstore.win, grbstore.gc, x, Bcvt(y));
-  if(grdisplay_mode) {
-    XDrawPoint(grdisplay, grwindow.win, grwindow.gc, x, Wcvt(y));
-    XFlush(grdisplay);
+  caml_gr_check_open();
+  if(caml_gr_remember_modeflag)
+    XDrawPoint(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x, Bcvt(y));
+  if(caml_gr_display_modeflag) {
+    XDrawPoint(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x, Wcvt(y));
+    XFlush(caml_gr_display);
   }
   return Val_unit;
 }
 
-value gr_moveto(value vx, value vy)
+value caml_gr_moveto(value vx, value vy)
 {
-  grx = Int_val(vx);
-  gry = Int_val(vy);
+  caml_gr_x = Int_val(vx);
+  caml_gr_y = Int_val(vy);
   return Val_unit;
 }
 
-value gr_current_x(void)
+value caml_gr_current_x(void)
 {
-  return Val_int(grx);
+  return Val_int(caml_gr_x);
 }
 
-value gr_current_y(void)
+value caml_gr_current_y(void)
 {
-  return Val_int(gry);
+  return Val_int(caml_gr_y);
 }
 
-value gr_lineto(value vx, value vy)
+value caml_gr_lineto(value vx, value vy)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
-  gr_check_open();
-  if(grremember_mode)
-    XDrawLine(grdisplay, grbstore.win, grbstore.gc,
-              grx, Bcvt(gry), x, Bcvt(y));
-  if(grdisplay_mode) {
-    XDrawLine(grdisplay, grwindow.win, grwindow.gc,
-          grx, Wcvt(gry), x, Wcvt(y));
-    XFlush(grdisplay);
+  caml_gr_check_open();
+  if(caml_gr_remember_modeflag)
+    XDrawLine(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc,
+              caml_gr_x, Bcvt(caml_gr_y), x, Bcvt(y));
+  if(caml_gr_display_modeflag) {
+    XDrawLine(caml_gr_display, caml_gr_window.win, caml_gr_window.gc,
+          caml_gr_x, Wcvt(caml_gr_y), x, Wcvt(y));
+    XFlush(caml_gr_display);
   }
-  grx = x;
-  gry = y;
+  caml_gr_x = x;
+  caml_gr_y = y;
   return Val_unit;
 }
 
-value gr_draw_rect(value vx, value vy, value vw, value vh)
+value caml_gr_draw_rect(value vx, value vy, value vw, value vh)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
   int w = Int_val(vw);
   int h = Int_val(vh);
 
-  gr_check_open();
-  y = Bcvt(y) - h + 1;
-  /* Correct for XDrawRectangle irritating habit of drawing a larger
-     rectangle hanging out one pixel below and to the right of the
-     expected rectangle */
-  if (w == 0 || h == 0) return Val_unit;
-  y += 1;
-  w -= 1;
-  h -= 1;
-  if(grremember_mode)
-    XDrawRectangle(grdisplay, grbstore.win, grbstore.gc,
-                   x, y, w, h);
-  if(grdisplay_mode) {
-    XDrawRectangle(grdisplay, grwindow.win, grwindow.gc,
-                   x, y, w, h);
-    XFlush(grdisplay);
+  caml_gr_check_open();
+  if(caml_gr_remember_modeflag)
+    XDrawRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc,
+                   x, Bcvt(y) - h, w, h);
+  if(caml_gr_display_modeflag) {
+    XDrawRectangle(caml_gr_display, caml_gr_window.win, caml_gr_window.gc,
+                   x, Wcvt(y) - h, w, h);
+    XFlush(caml_gr_display);
   }
   return Val_unit;
 }
 
-value gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2)
+value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
@@ -101,31 +93,31 @@ value gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, value
   int a1 = Int_val(va1);
   int a2 = Int_val(va2);
 
-  gr_check_open();
-  if(grremember_mode)
-    XDrawArc(grdisplay, grbstore.win, grbstore.gc,
+  caml_gr_check_open();
+  if(caml_gr_remember_modeflag)
+    XDrawArc(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc,
              x - rx, Bcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64);
-  if(grdisplay_mode) {
-    XDrawArc(grdisplay, grwindow.win, grwindow.gc,
+  if(caml_gr_display_modeflag) {
+    XDrawArc(caml_gr_display, caml_gr_window.win, caml_gr_window.gc,
          x - rx, Wcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64);
-    XFlush(grdisplay);
+    XFlush(caml_gr_display);
   }
   return Val_unit;
 }
 
-value gr_draw_arc(value *argv, int argc)
+value caml_gr_draw_arc(value *argv, int argc)
 {
-  return gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+  return caml_gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
 }
 
-value gr_set_line_width(value vwidth)
+value caml_gr_set_line_width(value vwidth)
 {
   int width = Int_val(vwidth);
 
-  gr_check_open();
-  XSetLineAttributes(grdisplay, grwindow.gc,
+  caml_gr_check_open();
+  XSetLineAttributes(caml_gr_display, caml_gr_window.gc,
                      width, LineSolid, CapRound, JoinRound);
-  XSetLineAttributes(grdisplay, grbstore.gc,
+  XSetLineAttributes(caml_gr_display, caml_gr_bstore.gc,
                      width, LineSolid, CapRound, JoinRound);
   return Val_unit;
 }
diff --git a/otherlibs/graph/dump_img.c b/otherlibs/graph/dump_img.c
index 9cdd43a5..1407cae6 100644
--- a/otherlibs/graph/dump_img.c
+++ b/otherlibs/graph/dump_img.c
@@ -11,21 +11,21 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: dump_img.c,v 1.10 2001/12/07 13:39:53 xleroy Exp $ */
+/* $Id: dump_img.c,v 1.11 2004/03/24 15:02:04 starynke Exp $ */
 
 #include "libgraph.h"
 #include "image.h"
 #include <alloc.h>
 #include <memory.h>
 
-value gr_dump_image(value image)
+value caml_gr_dump_image(value image)
 {
   int width, height, i, j;
   XImage * idata, * imask;
   value m = Val_unit;
 
   Begin_roots2(image, m);
-    gr_check_open();
+    caml_gr_check_open();
     width = Width_im(image);
     height = Height_im(image);
     m = alloc(height, 0);
@@ -35,15 +35,15 @@ value gr_dump_image(value image)
     }
 
     idata =
-      XGetImage(grdisplay, Data_im(image), 0, 0, width, height, (-1), ZPixmap);
+      XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1), ZPixmap);
     for (i = 0; i < height; i++)
       for (j = 0; j < width; j++)
-        Field(Field(m, i), j) = Val_int(gr_rgb_pixel(XGetPixel(idata, j, i)));
+        Field(Field(m, i), j) = Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i)));
     XDestroyImage(idata);
 
     if (Mask_im(image) != None) {
       imask =
-        XGetImage(grdisplay, Mask_im(image), 0, 0, width, height, 1, ZPixmap);
+        XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1, ZPixmap);
       for (i = 0; i < height; i++)
         for (j = 0; j < width; j++)
           if (XGetPixel(imask, j, i) == 0)
diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c
index ae283102..d2da5bed 100644
--- a/otherlibs/graph/events.c
+++ b/otherlibs/graph/events.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: events.c,v 1.15 2002/11/17 16:29:47 xleroy Exp $ */
+/* $Id: events.c,v 1.17 2004/05/30 10:25:08 xleroy Exp $ */
 
 #include <signal.h>
 #include "libgraph.h"
@@ -32,76 +32,76 @@ struct event_data {
   unsigned char key;
 };
 
-static struct event_data gr_queue[SIZE_QUEUE];
-static unsigned int gr_head = 0;       /* position of next read */
-static unsigned int gr_tail = 0;       /* position of next write */
+static struct event_data caml_gr_queue[SIZE_QUEUE];
+static unsigned int caml_gr_head = 0;       /* position of next read */
+static unsigned int caml_gr_tail = 0;       /* position of next write */
 
-#define QueueIsEmpty (gr_tail == gr_head)
+#define QueueIsEmpty (caml_gr_tail == caml_gr_head)
 
-static void gr_enqueue_event(int kind, int mouse_x, int mouse_y,
+static void caml_gr_enqueue_event(int kind, int mouse_x, int mouse_y,
                              int button, int key)
 {
   struct event_data * ev;
 
-  ev = &(gr_queue[gr_tail]);
+  ev = &(caml_gr_queue[caml_gr_tail]);
   ev->kind = kind;
   ev->mouse_x = mouse_x;
   ev->mouse_y = mouse_y;
   ev->button = (button != 0);
   ev->key = key;
-  gr_tail = (gr_tail + 1) % SIZE_QUEUE;
+  caml_gr_tail = (caml_gr_tail + 1) % SIZE_QUEUE;
   /* If queue was full, it now appears empty; drop oldest entry from queue. */
-  if (QueueIsEmpty) gr_head = (gr_head + 1) % SIZE_QUEUE;
+  if (QueueIsEmpty) caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE;
 }
 
 #define BUTTON_STATE(state) \
   ((state) & (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask))
 
-void gr_handle_event(XEvent * event)
+void caml_gr_handle_event(XEvent * event)
 {
   switch (event->type) {
 
   case Expose:
-    XCopyArea(grdisplay, grbstore.win, grwindow.win, grwindow.gc,
-              event->xexpose.x, event->xexpose.y + grbstore.h - grwindow.h,
+    XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, caml_gr_window.gc,
+              event->xexpose.x, event->xexpose.y + caml_gr_bstore.h - caml_gr_window.h,
               event->xexpose.width, event->xexpose.height,
               event->xexpose.x, event->xexpose.y);
-    XFlush(grdisplay);
+    XFlush(caml_gr_display);
     break;
 
   case ConfigureNotify:
-    grwindow.w = event->xconfigure.width;
-    grwindow.h = event->xconfigure.height;
-    if (grwindow.w > grbstore.w || grwindow.h > grbstore.h) {
+    caml_gr_window.w = event->xconfigure.width;
+    caml_gr_window.h = event->xconfigure.height;
+    if (caml_gr_window.w > caml_gr_bstore.w || caml_gr_window.h > caml_gr_bstore.h) {
 
       /* Allocate a new backing store large enough to accomodate
          both the old backing store and the current window. */
       struct canvas newbstore;
-      newbstore.w = max(grwindow.w, grbstore.w);
-      newbstore.h = max(grwindow.h, grbstore.h);
+      newbstore.w = max(caml_gr_window.w, caml_gr_bstore.w);
+      newbstore.h = max(caml_gr_window.h, caml_gr_bstore.h);
       newbstore.win =
-        XCreatePixmap(grdisplay, grwindow.win, newbstore.w, newbstore.h,
-                      XDefaultDepth(grdisplay, grscreen));
-      newbstore.gc = XCreateGC(grdisplay, newbstore.win, 0, NULL);
-      XSetBackground(grdisplay, newbstore.gc, grwhite);
-      XSetForeground(grdisplay, newbstore.gc, grwhite);
-      XFillRectangle(grdisplay, newbstore.win, newbstore.gc,
+        XCreatePixmap(caml_gr_display, caml_gr_window.win, newbstore.w, newbstore.h,
+                      XDefaultDepth(caml_gr_display, caml_gr_screen));
+      newbstore.gc = XCreateGC(caml_gr_display, newbstore.win, 0, NULL);
+      XSetBackground(caml_gr_display, newbstore.gc, caml_gr_white);
+      XSetForeground(caml_gr_display, newbstore.gc, caml_gr_white);
+      XFillRectangle(caml_gr_display, newbstore.win, newbstore.gc,
                      0, 0, newbstore.w, newbstore.h);
-      XSetForeground(grdisplay, newbstore.gc, grcolor);
-      if (grfont != NULL)
-        XSetFont(grdisplay, newbstore.gc, grfont->fid);
+      XSetForeground(caml_gr_display, newbstore.gc, caml_gr_color);
+      if (caml_gr_font != NULL)
+        XSetFont(caml_gr_display, newbstore.gc, caml_gr_font->fid);
 
       /* Copy the old backing store into the new one */
-      XCopyArea(grdisplay, grbstore.win, newbstore.win, newbstore.gc,
-                0, 0, grbstore.w, grbstore.h, 0, newbstore.h - grbstore.h);
+      XCopyArea(caml_gr_display, caml_gr_bstore.win, newbstore.win, newbstore.gc,
+                0, 0, caml_gr_bstore.w, caml_gr_bstore.h, 0, newbstore.h - caml_gr_bstore.h);
 
       /* Free the old backing store */
-      XFreeGC(grdisplay, grbstore.gc);
-      XFreePixmap(grdisplay, grbstore.win);
+      XFreeGC(caml_gr_display, caml_gr_bstore.gc);
+      XFreePixmap(caml_gr_display, caml_gr_bstore.win);
 
       /* Use the new backing store */
-      grbstore = newbstore;
-      XFlush(grdisplay);
+      caml_gr_bstore = newbstore;
+      XFlush(caml_gr_display);
     }
     break;
 
@@ -117,25 +117,25 @@ void gr_handle_event(XEvent * event)
       nchars = XLookupString(&(event->xkey), keytxt, sizeof(keytxt),
                              &thekey, 0);
       for (p = keytxt; nchars > 0; p++, nchars--)
-        gr_enqueue_event(event->type, event->xkey.x, event->xkey.y,
+        caml_gr_enqueue_event(event->type, event->xkey.x, event->xkey.y,
                          BUTTON_STATE(event->xkey.state), *p);
       break;
     }
 
   case ButtonPress:
   case ButtonRelease:
-    gr_enqueue_event(event->type, event->xbutton.x, event->xbutton.y,
+    caml_gr_enqueue_event(event->type, event->xbutton.x, event->xbutton.y,
                      event->type == ButtonPress, 0);
     break;
 
   case MotionNotify:
-    gr_enqueue_event(event->type, event->xmotion.x, event->xmotion.y,
+    caml_gr_enqueue_event(event->type, event->xmotion.x, event->xmotion.y,
                      BUTTON_STATE(event->xmotion.state), 0);
     break;
   }
 }
 
-static value gr_wait_allocate_result(int mouse_x, int mouse_y, int button,
+static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y, int button,
                                      int keypressed, int key)
 {
   value res = alloc_small(5, 0);
@@ -147,7 +147,7 @@ static value gr_wait_allocate_result(int mouse_x, int mouse_y, int button,
   return res;
 }
 
-static value gr_wait_event_poll(void)
+static value caml_gr_wait_event_poll(void)
 {
   int mouse_x, mouse_y, button, key, keypressed;
   Window rootwin, childwin;
@@ -155,7 +155,7 @@ static value gr_wait_event_poll(void)
   unsigned int modifiers;
   unsigned int i;
 
-  if (XQueryPointer(grdisplay, grwindow.win,
+  if (XQueryPointer(caml_gr_display, caml_gr_window.win,
                     &rootwin, &childwin,
                     &root_x, &root_y, &win_x, &win_y,
                     &modifiers)) {
@@ -170,99 +170,80 @@ static value gr_wait_event_poll(void)
   /* Look inside event queue for pending KeyPress events */
   key = 0;
   keypressed = False;
-  for (i = gr_head; i != gr_tail; i = (i + 1) % SIZE_QUEUE) {
-    if (gr_queue[i].kind == KeyPress) {
+  for (i = caml_gr_head; i != caml_gr_tail; i = (i + 1) % SIZE_QUEUE) {
+    if (caml_gr_queue[i].kind == KeyPress) {
       keypressed = True;
-      key = gr_queue[i].key;
+      key = caml_gr_queue[i].key;
       break;
     }
   }
-  return gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key);
+  return caml_gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key);
 }
 
-static value gr_wait_event_in_queue(long mask)
+static value caml_gr_wait_event_in_queue(long mask)
 {
   struct event_data * ev;
   /* Pop events in queue until one matches mask. */
-  while (gr_head != gr_tail) {
-    ev = &(gr_queue[gr_head]);
-    gr_head = (gr_head + 1) % SIZE_QUEUE;
+  while (caml_gr_head != caml_gr_tail) {
+    ev = &(caml_gr_queue[caml_gr_head]);
+    caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE;
     if ((ev->kind == KeyPress && (mask & KeyPressMask))
         || (ev->kind == ButtonPress && (mask & ButtonPressMask))
         || (ev->kind == ButtonRelease && (mask & ButtonReleaseMask))
         || (ev->kind == MotionNotify && (mask & PointerMotionMask)))
-      return gr_wait_allocate_result(ev->mouse_x, ev->mouse_y,
+      return caml_gr_wait_allocate_result(ev->mouse_x, ev->mouse_y,
                                      ev->button, ev->kind == KeyPress,
                                      ev->key);
   }
   return Val_false;
 }
 
-static value gr_wait_event_blocking(long mask)
+static value caml_gr_wait_event_blocking(long mask)
 {
-#ifdef POSIX_SIGNALS
-  sigset_t sigset;
-#else
-  void (*oldsig)();
-#endif
   XEvent event;
   fd_set readfds;
   value res;
 
   /* First see if we have a matching event in the queue */
-  res = gr_wait_event_in_queue(mask);
+  res = caml_gr_wait_event_in_queue(mask);
   if (res != Val_false) return res;
 
   /* Increase the selected events if required */
-  if ((mask & ~grselected_events) != 0) {
-    grselected_events |= mask;
-    XSelectInput(grdisplay, grwindow.win, grselected_events);
+  if ((mask & ~caml_gr_selected_events) != 0) {
+    caml_gr_selected_events |= mask;
+    XSelectInput(caml_gr_display, caml_gr_window.win, caml_gr_selected_events);
   }
 
-  /* Block or deactivate the EVENT signal */
-#ifdef POSIX_SIGNALS
-  sigemptyset(&sigset);
-  sigaddset(&sigset, EVENT_SIGNAL);
-  sigprocmask(SIG_BLOCK, &sigset, NULL);
-#else
-  oldsig = signal(EVENT_SIGNAL, SIG_IGN);
-#endif
-
   /* Replenish our event queue from that of X11 */
+  caml_gr_ignore_sigio = True;
   while (1) {
-    if (XCheckMaskEvent(grdisplay, -1 /*all events*/, &event)) {
+    if (XCheckMaskEvent(caml_gr_display, -1 /*all events*/, &event)) {
       /* One event available: add it to our queue */
-      gr_handle_event(&event);
+      caml_gr_handle_event(&event);
       /* See if we now have a matching event */
-      res = gr_wait_event_in_queue(mask);
+      res = caml_gr_wait_event_in_queue(mask);
       if (res != Val_false) break;
     } else {
       /* No event available: block on input socket until one is */
       FD_ZERO(&readfds);
-      FD_SET(ConnectionNumber(grdisplay), &readfds);
+      FD_SET(ConnectionNumber(caml_gr_display), &readfds);
       enter_blocking_section();
       select(FD_SETSIZE, &readfds, NULL, NULL, NULL);
       leave_blocking_section();
     }
   }
-
-  /* Restore the EVENT signal to its initial state */
-#ifdef POSIX_SIGNALS
-  sigprocmask(SIG_UNBLOCK, &sigset, NULL);
-#else
-  signal(EVENT_SIGNAL, oldsig);
-#endif
+  caml_gr_ignore_sigio = False;
 
   /* Return result */
   return res;
 }
 
-value gr_wait_event(value eventlist) /* ML */
+value caml_gr_wait_event(value eventlist) /* ML */
 {
   int mask;
   Bool poll;
 
-  gr_check_open();
+  caml_gr_check_open();
   mask = 0;
   poll = False;
   while (eventlist != Val_int(0)) {
@@ -281,7 +262,7 @@ value gr_wait_event(value eventlist) /* ML */
     eventlist = Field(eventlist, 1);
   }
   if (poll)
-    return gr_wait_event_poll();
+    return caml_gr_wait_event_poll();
   else
-    return gr_wait_event_blocking(mask);
+    return caml_gr_wait_event_blocking(mask);
 }
diff --git a/otherlibs/graph/fill.c b/otherlibs/graph/fill.c
index e0ed8643..a33eccde 100644
--- a/otherlibs/graph/fill.c
+++ b/otherlibs/graph/fill.c
@@ -11,57 +11,57 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: fill.c,v 1.12 2001/12/07 13:39:53 xleroy Exp $ */
+/* $Id: fill.c,v 1.14 2004/05/30 14:11:41 xleroy Exp $ */
 
 #include "libgraph.h"
 #include <memory.h>
 
-value gr_fill_rect(value vx, value vy, value vw, value vh)
+value caml_gr_fill_rect(value vx, value vy, value vw, value vh)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
   int w = Int_val(vw);
   int h = Int_val(vh);
 
-  gr_check_open();
-  if(grremember_mode)
-    XFillRectangle(grdisplay, grbstore.win, grbstore.gc,
-                   x, Bcvt(y) - h + 1, w, h);
-  if(grdisplay_mode) {
-    XFillRectangle(grdisplay, grwindow.win, grwindow.gc,
-           x, Wcvt(y) - h + 1, w, h);
-    XFlush(grdisplay);
+  caml_gr_check_open();
+  if(caml_gr_remember_modeflag)
+    XFillRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc,
+                   x, Bcvt(y) - h, w + 1, h + 1);
+  if(caml_gr_display_modeflag) {
+    XFillRectangle(caml_gr_display, caml_gr_window.win, caml_gr_window.gc,
+           x, Wcvt(y) - h, w + 1, h + 1);
+    XFlush(caml_gr_display);
   }
   return Val_unit;
 }
 
-value gr_fill_poly(value array)
+value caml_gr_fill_poly(value array)
 {
   XPoint * points;
   int npoints, i;
 
-  gr_check_open();
+  caml_gr_check_open();
   npoints = Wosize_val(array);
   points = (XPoint *) stat_alloc(npoints * sizeof(XPoint));
   for (i = 0; i < npoints; i++) {
     points[i].x = Int_val(Field(Field(array, i), 0));
     points[i].y = Bcvt(Int_val(Field(Field(array, i), 1)));
   }
-  if(grremember_mode)
-    XFillPolygon(grdisplay, grbstore.win, grbstore.gc, points,
+  if(caml_gr_remember_modeflag)
+    XFillPolygon(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, points,
                  npoints, Complex, CoordModeOrigin);
-  if(grdisplay_mode) {
+  if(caml_gr_display_modeflag) {
     for (i = 0; i < npoints; i++)
       points[i].y = BtoW(points[i].y);
-    XFillPolygon(grdisplay, grwindow.win, grwindow.gc, points,
+    XFillPolygon(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, points,
          npoints, Complex, CoordModeOrigin);
-    XFlush(grdisplay);
+    XFlush(caml_gr_display);
   }
   stat_free((char *) points);
   return Val_unit;
 }
 
-value gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2)
+value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
@@ -70,19 +70,19 @@ value gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, value
   int a1 = Int_val(va1);
   int a2 = Int_val(va2);
 
-  gr_check_open();
-  if(grremember_mode)
-    XFillArc(grdisplay, grbstore.win, grbstore.gc,
+  caml_gr_check_open();
+  if(caml_gr_remember_modeflag)
+    XFillArc(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc,
              x - rx, Bcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64);
-  if(grdisplay_mode) {
-    XFillArc(grdisplay, grwindow.win, grwindow.gc,
+  if(caml_gr_display_modeflag) {
+    XFillArc(caml_gr_display, caml_gr_window.win, caml_gr_window.gc,
          x - rx, Wcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64);
-    XFlush(grdisplay);
+    XFlush(caml_gr_display);
   }
   return Val_unit;
 }
 
-value gr_fill_arc(value *argv, int argc)
+value caml_gr_fill_arc(value *argv, int argc)
 {
-  return gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+  return caml_gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
 }
diff --git a/otherlibs/graph/graphics.ml b/otherlibs/graph/graphics.ml
index 3c206cf8..d3c8ca66 100644
--- a/otherlibs/graph/graphics.ml
+++ b/otherlibs/graph/graphics.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: graphics.ml,v 1.24 2002/07/23 07:46:22 xleroy Exp $ *)
+(* $Id: graphics.ml,v 1.25 2004/03/24 15:02:06 starynke Exp $ *)
 
 exception Graphic_failure of string
 
@@ -20,10 +20,10 @@ exception Graphic_failure of string
 let _ =
   Callback.register_exception "Graphics.Graphic_failure" (Graphic_failure "")
 
-external raw_open_graph: string -> unit = "gr_open_graph"
-external raw_close_graph: unit -> unit = "gr_close_graph"
-external sigio_signal: unit -> int = "gr_sigio_signal"
-external sigio_handler: int -> unit = "gr_sigio_handler"
+external raw_open_graph: string -> unit = "caml_gr_open_graph"
+external raw_close_graph: unit -> unit = "caml_gr_close_graph"
+external sigio_signal: unit -> int = "caml_gr_sigio_signal"
+external sigio_handler: int -> unit = "caml_gr_sigio_handler"
 
 let unix_open_graph arg =
   Sys.set_signal (sigio_signal()) (Sys.Signal_handle sigio_handler);
@@ -40,16 +40,16 @@ let (open_graph, close_graph) =
   | "MacOS" -> (raw_open_graph, raw_close_graph)
   | _ -> invalid_arg ("Graphics: unknown OS type: " ^ Sys.os_type)
 
-external set_window_title : string -> unit = "gr_set_window_title"
-external clear_graph : unit -> unit = "gr_clear_graph"
-external size_x : unit -> int = "gr_size_x"
-external size_y : unit -> int = "gr_size_y"
+external set_window_title : string -> unit = "caml_gr_set_window_title"
+external clear_graph : unit -> unit = "caml_gr_clear_graph"
+external size_x : unit -> int = "caml_gr_size_x"
+external size_y : unit -> int = "caml_gr_size_y"
 
 (* Double-buffering *)
 
-external display_mode : bool -> unit = "gr_display_mode"
-external remember_mode : bool -> unit = "gr_remember_mode"
-external synchronize : unit -> unit = "gr_synchronize"
+external display_mode : bool -> unit = "caml_gr_display_mode"
+external remember_mode : bool -> unit = "caml_gr_remember_mode"
+external synchronize : unit -> unit = "caml_gr_synchronize"
 
 let auto_synchronize = function
   | true -> display_mode true; remember_mode true; synchronize ()
@@ -63,7 +63,7 @@ type color = int
 
 let rgb r g b = (r lsl 16) + (g lsl 8) + b
 
-external set_color : color -> unit = "gr_set_color"
+external set_color : color -> unit = "caml_gr_set_color"
 
 let black   = 0x000000
 and white   = 0xFFFFFF
@@ -79,22 +79,22 @@ and foreground = black
 
 (* Drawing *)
 
-external plot : int -> int -> unit = "gr_plot"
+external plot : int -> int -> unit = "caml_gr_plot"
 let plots points =
   for i = 0 to Array.length points - 1 do
     let (x, y) = points.(i) in
     plot x y;
   done
 ;;
-external point_color : int -> int -> color = "gr_point_color"
-external moveto : int -> int -> unit = "gr_moveto"
-external current_x : unit -> int = "gr_current_x"
-external current_y : unit -> int = "gr_current_y"
+external point_color : int -> int -> color = "caml_gr_point_color"
+external moveto : int -> int -> unit = "caml_gr_moveto"
+external current_x : unit -> int = "caml_gr_current_x"
+external current_y : unit -> int = "caml_gr_current_y"
 let current_point () = current_x (), current_y ()
-external lineto : int -> int -> unit = "gr_lineto"
+external lineto : int -> int -> unit = "caml_gr_lineto"
 let rlineto x y = lineto (current_x () + x) (current_y () + y)
 let rmoveto x y = moveto (current_x () + x) (current_y () + y)
-external draw_rect : int -> int -> int -> int -> unit = "gr_draw_rect"
+external draw_rect : int -> int -> int -> int -> unit = "caml_gr_draw_rect"
 let draw_poly, draw_poly_line =
   let dodraw close_flag points =
     if Array.length points > 0 then begin
@@ -119,25 +119,25 @@ let draw_segments segs =
   moveto savex savey;
 ;;
 external draw_arc : int -> int -> int -> int -> int -> int -> unit
-               = "gr_draw_arc" "gr_draw_arc_nat"
+               = "caml_gr_draw_arc" "caml_gr_draw_arc_nat"
 let draw_ellipse x y rx ry = draw_arc x y rx ry 0 360
 let draw_circle x y r = draw_arc x y r r 0 360
-external set_line_width : int -> unit = "gr_set_line_width"
+external set_line_width : int -> unit = "caml_gr_set_line_width"
 
-external fill_rect : int -> int -> int -> int -> unit = "gr_fill_rect"
-external fill_poly : (int * int) array -> unit = "gr_fill_poly"
+external fill_rect : int -> int -> int -> int -> unit = "caml_gr_fill_rect"
+external fill_poly : (int * int) array -> unit = "caml_gr_fill_poly"
 external fill_arc : int -> int -> int -> int -> int -> int -> unit
-               = "gr_fill_arc" "gr_fill_arc_nat"
+               = "caml_gr_fill_arc" "caml_gr_fill_arc_nat"
 let fill_ellipse x y rx ry = fill_arc x y rx ry 0 360
 let fill_circle x y r = fill_arc x y r r 0 360
 
 (* Text *)
 
-external draw_char : char -> unit = "gr_draw_char"
-external draw_string : string -> unit = "gr_draw_string"
-external set_font : string -> unit = "gr_set_font"
-external set_text_size : int -> unit = "gr_set_text_size"
-external text_size : string -> int * int = "gr_text_size"
+external draw_char : char -> unit = "caml_gr_draw_char"
+external draw_string : string -> unit = "caml_gr_draw_string"
+external set_font : string -> unit = "caml_gr_set_font"
+external set_text_size : int -> unit = "caml_gr_set_text_size"
+external text_size : string -> int * int = "caml_gr_text_size"
 
 (* Images *)
 
@@ -145,11 +145,11 @@ type image
 
 let transp = -1
 
-external make_image : color array array -> image = "gr_make_image"
-external dump_image : image -> color array array = "gr_dump_image"
-external draw_image : image -> int -> int -> unit = "gr_draw_image"
-external create_image : int -> int -> image = "gr_create_image"
-external blit_image : image -> int -> int -> unit = "gr_blit_image"
+external make_image : color array array -> image = "caml_gr_make_image"
+external dump_image : image -> color array array = "caml_gr_dump_image"
+external draw_image : image -> int -> int -> unit = "caml_gr_draw_image"
+external create_image : int -> int -> image = "caml_gr_create_image"
+external blit_image : image -> int -> int -> unit = "caml_gr_blit_image"
 
 let get_image x y w h =
   let image = create_image w h in
@@ -172,7 +172,7 @@ type event =
   | Mouse_motion
   | Poll
 
-external wait_next_event : event list -> status = "gr_wait_event"
+external wait_next_event : event list -> status = "caml_gr_wait_event"
 
 let mouse_pos () =
   let e = wait_next_event [Poll] in (e.mouse_x, e.mouse_y)
@@ -188,7 +188,7 @@ let key_pressed () =
 
 (*** Sound *)
 
-external sound : int -> int -> unit = "gr_sound"
+external sound : int -> int -> unit = "caml_gr_sound"
 
 (* Splines *)
 let add (x1, y1) (x2, y2) = (x1 +. x2, y1 +. y2)
diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli
index 6ab5d73f..b865c6f2 100644
--- a/otherlibs/graph/graphics.mli
+++ b/otherlibs/graph/graphics.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: graphics.mli,v 1.35 2002/01/20 15:12:20 doligez Exp $ *)
+(* $Id: graphics.mli,v 1.36 2004/03/24 15:02:06 starynke Exp $ *)
 
 (** Machine-independent graphics primitives. *)
 
@@ -35,13 +35,13 @@ val close_graph : unit -> unit
 val set_window_title : string -> unit
 (** Set the title of the graphics window. *)
 
-external clear_graph : unit -> unit = "gr_clear_graph"
+external clear_graph : unit -> unit = "caml_gr_clear_graph"
 (** Erase the graphics window. *)
 
-external size_x : unit -> int = "gr_size_x"
+external size_x : unit -> int = "caml_gr_size_x"
 (** See {!Graphics.size_y}. *)
 
-external size_y : unit -> int = "gr_size_y"
+external size_y : unit -> int = "caml_gr_size_y"
 (** Return the size of the graphics window. Coordinates of the screen
    pixels range over [0 .. size_x()-1] and [0 .. size_y()-1].
    Drawings outside of this rectangle are clipped, without causing
@@ -61,7 +61,7 @@ val rgb : int -> int -> int -> color
    component [r], green component [g], and blue component [b].
    [r], [g] and [b] are in the range [0..255]. *)
 
-external set_color : color -> unit = "gr_set_color"
+external set_color : color -> unit = "caml_gr_set_color"
 (** Set the current drawing color. *)
 
 val background : color
@@ -89,32 +89,32 @@ val magenta : color
 
 (** {6 Point and line drawing} *)
 
-external plot : int -> int -> unit = "gr_plot"
+external plot : int -> int -> unit = "caml_gr_plot"
 (** Plot the given point with the current drawing color. *)
 
 val plots : (int * int) array -> unit
 (** Plot the given points with the current drawing color. *)
 
-external point_color : int -> int -> color = "gr_point_color"
+external point_color : int -> int -> color = "caml_gr_point_color"
 (** Return the color of the given point in the backing store
    (see "Double buffering" below). *)
 
-external moveto : int -> int -> unit = "gr_moveto"
+external moveto : int -> int -> unit = "caml_gr_moveto"
 (** Position the current point. *)
 
 val rmoveto : int -> int -> unit
 (** [rmoveto dx dy] translates the current point by the given vector. *)
 
-external current_x : unit -> int = "gr_current_x"
+external current_x : unit -> int = "caml_gr_current_x"
 (** Return the abscissa of the current point. *)
 
-external current_y : unit -> int = "gr_current_y"
+external current_y : unit -> int = "caml_gr_current_y"
 (** Return the ordinate of the current point. *)
 
 val current_point : unit -> int * int
 (** Return the position of the current point. *)
 
-external lineto : int -> int -> unit = "gr_lineto"
+external lineto : int -> int -> unit = "caml_gr_lineto"
 (** Draw a line with endpoints the current point and the given point,
    and move the current point to the given point. *)
 
@@ -128,7 +128,7 @@ val curveto : int * int -> int * int -> int * int -> unit
    the current point to point [d], with control points [b] and
    [c], and moves the current point to [d]. *)
 
-external draw_rect : int -> int -> int -> int -> unit = "gr_draw_rect"
+external draw_rect : int -> int -> int -> int -> unit = "caml_gr_draw_rect"
 (** [draw_rect x y w h] draws the rectangle with lower left corner
    at [x,y], width [w] and height [h].
    The current point is unchanged. *)
@@ -155,7 +155,7 @@ val draw_segments : (int * int * int * int) array -> unit
 
 external draw_arc :
   int -> int -> int -> int -> int -> int ->
-    unit = "gr_draw_arc" "gr_draw_arc_nat"
+    unit = "caml_gr_draw_arc" "caml_gr_draw_arc_nat"
 (** [draw_arc x y rx ry a1 a2] draws an elliptical arc with center
    [x,y], horizontal radius [rx], vertical radius [ry], from angle
    [a1] to angle [a2] (in degrees). The current point is unchanged. *)
@@ -169,7 +169,7 @@ val draw_circle : int -> int -> int -> unit
 (** [draw_circle x y r] draws a circle with center [x,y] and
    radius [r]. The current point is unchanged. *)
 
-external set_line_width : int -> unit = "gr_set_line_width"
+external set_line_width : int -> unit = "caml_gr_set_line_width"
 (** Set the width of points and lines drawn with the functions above.
    Under X Windows, [set_line_width 0] selects a width of 1 pixel
    and a faster, but less precise drawing algorithm than the one
@@ -177,15 +177,15 @@ external set_line_width : int -> unit = "gr_set_line_width"
 
 (** {6 Text drawing} *)
 
-external draw_char : char -> unit = "gr_draw_char"
+external draw_char : char -> unit = "caml_gr_draw_char"
 (** See {!Graphics.draw_string}.*)
 
-external draw_string : string -> unit = "gr_draw_string"
+external draw_string : string -> unit = "caml_gr_draw_string"
 (** Draw a character or a character string with lower left corner
    at current position. After drawing, the current position is set
    to the lower right corner of the text drawn. *)
 
-external set_font : string -> unit = "gr_set_font"
+external set_font : string -> unit = "caml_gr_set_font"
 (** Set the font used for drawing text.
    The interpretation of the arguments to [set_font] 
    is implementation-dependent. *)
@@ -195,24 +195,24 @@ val set_text_size : int -> unit
    The interpretation of the arguments to [set_text_size] 
    is implementation-dependent. *)
 
-external text_size : string -> int * int = "gr_text_size"
+external text_size : string -> int * int = "caml_gr_text_size"
 (** Return the dimensions of the given text, if it were drawn with
    the current font and size. *)
 
 
 (** {6 Filling} *)
 
-external fill_rect : int -> int -> int -> int -> unit = "gr_fill_rect"
+external fill_rect : int -> int -> int -> int -> unit = "caml_gr_fill_rect"
 (** [fill_rect x y w h] fills the rectangle with lower left corner
    at [x,y], width [w] and height [h], with the current color. *)
 
-external fill_poly : (int * int) array -> unit = "gr_fill_poly"
+external fill_poly : (int * int) array -> unit = "caml_gr_fill_poly"
 (** Fill the given polygon with the current color. The array
    contains the coordinates of the vertices of the polygon. *)
 
 external fill_arc :
   int -> int -> int -> int -> int -> int ->
-    unit = "gr_fill_arc" "gr_fill_arc_nat"
+    unit = "caml_gr_fill_arc" "caml_gr_fill_arc_nat"
 (** Fill an elliptical pie slice with the current color. The
    parameters are the same as for {!Graphics.draw_arc}. *)
 
@@ -239,29 +239,29 @@ val transp : color
    of the corresponding point in the image. This allows superimposing
    an image over an existing background. *)
 
-external make_image : color array array -> image = "gr_make_image"
+external make_image : color array array -> image = "caml_gr_make_image"
 (** Convert the given color matrix to an image.
    Each sub-array represents one horizontal line. All sub-arrays
    must have the same length; otherwise, exception [Graphic_failure]
    is raised. *)
 
-external dump_image : image -> color array array = "gr_dump_image"
+external dump_image : image -> color array array = "caml_gr_dump_image"
 (** Convert an image to a color matrix. *)
 
-external draw_image : image -> int -> int -> unit = "gr_draw_image"
+external draw_image : image -> int -> int -> unit = "caml_gr_draw_image"
 (** Draw the given image with lower left corner at the given point. *)
 
 val get_image : int -> int -> int -> int -> image
 (** Capture the contents of a rectangle on the screen as an image.
    The parameters are the same as for {!Graphics.fill_rect}. *)
 
-external create_image : int -> int -> image = "gr_create_image"
+external create_image : int -> int -> image = "caml_gr_create_image"
 (** [create_image w h] returns a new image [w] pixels wide and [h]
    pixels tall, to be used in conjunction with [blit_image].
    The initial image contents are random, except that no point
    is transparent. *)
 
-external blit_image : image -> int -> int -> unit = "gr_blit_image"
+external blit_image : image -> int -> int -> unit = "caml_gr_blit_image"
 (** [blit_image img x y] copies screen pixels into the image [img],
    modifying [img] in-place. The pixels copied are those inside the
    rectangle with lower left corner at [x,y], and width and height
@@ -290,7 +290,7 @@ type event =
 (** To specify events to wait for. *)
 
 
-external wait_next_event : event list -> status = "gr_wait_event"
+external wait_next_event : event list -> status = "caml_gr_wait_event"
 (** Wait until one of the events specified in the given event list
    occurs, and return the status of the mouse and keyboard at
    that time. If [Poll] is given in the event list, return immediately
@@ -322,7 +322,7 @@ val key_pressed : unit -> bool
 
 (** {6 Sound} *)
 
-external sound : int -> int -> unit = "gr_sound"
+external sound : int -> int -> unit = "caml_gr_sound"
 (** [sound freq dur] plays a sound at frequency [freq] (in hertz)
    for a duration [dur] (in milliseconds). *)
 
@@ -350,13 +350,13 @@ val auto_synchronize : bool -> unit
    
    The default drawing mode corresponds to [auto_synchronize true]. *)
 
-external synchronize : unit -> unit = "gr_synchronize"
+external synchronize : unit -> unit = "caml_gr_synchronize"
 (** Synchronize the backing store and the on-screen window, by
    copying the contents of the backing store onto the graphics
    window. *)
 
 
-external display_mode : bool -> unit = "gr_display_mode"
+external display_mode : bool -> unit = "caml_gr_display_mode"
 (** Set display mode on or off. When turned on, drawings are done
    in the graphics window; when turned off, drawings do not affect
    the graphics window.  This occurs independently of
@@ -364,7 +364,7 @@ external display_mode : bool -> unit = "gr_display_mode"
    below). Default display mode is on. *)
 
 
-external remember_mode : bool -> unit = "gr_remember_mode"
+external remember_mode : bool -> unit = "caml_gr_remember_mode"
 (** Set remember mode on or off. When turned on, drawings are done
    in the backing store; when turned off, the backing store is
    unaffected by drawings.  This occurs independently of drawing
diff --git a/otherlibs/graph/graphicsX11.ml b/otherlibs/graph/graphicsX11.ml
index cb3e6093..07528af3 100644
--- a/otherlibs/graph/graphicsX11.ml
+++ b/otherlibs/graph/graphicsX11.ml
@@ -11,20 +11,20 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: graphicsX11.ml,v 1.2 2001/12/07 13:39:54 xleroy Exp $ *)
+(* $Id: graphicsX11.ml,v 1.3 2004/03/24 15:02:06 starynke Exp $ *)
 
 (* Module [GraphicsX11]: additional graphics primitives for the X Windows system *)
 
 type window_id = string
 
-external window_id : unit -> window_id = "gr_window_id"
+external window_id : unit -> window_id = "caml_gr_window_id"
 
 let subwindows = Hashtbl.create 13
 
 external open_subwindow : int -> int -> int -> int -> window_id 
-    = "gr_open_subwindow"
+    = "caml_gr_open_subwindow"
 external close_subwindow : window_id -> unit
-    = "gr_close_subwindow"
+    = "caml_gr_close_subwindow"
 
 let open_subwindow ~x ~y ~width ~height =
   let wid = open_subwindow x y width height in
diff --git a/otherlibs/graph/image.c b/otherlibs/graph/image.c
index 4e207a41..302b4136 100644
--- a/otherlibs/graph/image.c
+++ b/otherlibs/graph/image.c
@@ -11,22 +11,22 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: image.c,v 1.12 2001/12/07 13:39:54 xleroy Exp $ */
+/* $Id: image.c,v 1.13 2004/03/24 15:02:05 starynke Exp $ */
 
 #include "libgraph.h"
 #include "image.h"
 #include <alloc.h>
 #include <custom.h>
 
-static void gr_free_image(value im)
+static void caml_gr_free_image(value im)
 {
-  XFreePixmap(grdisplay, Data_im(im));
-  if (Mask_im(im) != None) XFreePixmap(grdisplay, Mask_im(im));
+  XFreePixmap(caml_gr_display, Data_im(im));
+  if (Mask_im(im) != None) XFreePixmap(caml_gr_display, Mask_im(im));
 }
 
 static struct custom_operations image_ops = {
   "_image",
-  gr_free_image,
+  caml_gr_free_image,
   custom_compare_default,
   custom_hash_default,
   custom_serialize_default,
@@ -35,71 +35,73 @@ static struct custom_operations image_ops = {
 
 #define Max_image_mem 2000000
 
-value gr_new_image(int w, int h)
+value caml_gr_new_image(int w, int h)
 {
   value res = alloc_custom(&image_ops, sizeof(struct grimage),
                            w * h, Max_image_mem);
   Width_im(res) = w;
   Height_im(res) = h;
-  Data_im(res) = XCreatePixmap(grdisplay, grwindow.win, w, h,
-                               XDefaultDepth(grdisplay, grscreen));
+  Data_im(res) = XCreatePixmap(caml_gr_display, caml_gr_window.win, w, h,
+                               XDefaultDepth(caml_gr_display, caml_gr_screen));
   Mask_im(res) = None;
   return res;
 }
 
-value gr_create_image(value vw, value vh)
+value caml_gr_create_image(value vw, value vh)
 {
-  gr_check_open();
-  return gr_new_image(Int_val(vw), Int_val(vh));
+  caml_gr_check_open();
+  return caml_gr_new_image(Int_val(vw), Int_val(vh));
 }
 
-value gr_blit_image(value im, value vx, value vy)
+value caml_gr_blit_image(value im, value vx, value vy)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
-  gr_check_open();
-  XCopyArea(grdisplay, grbstore.win, Data_im(im), grbstore.gc,
+  caml_gr_check_open();
+  XCopyArea(caml_gr_display, caml_gr_bstore.win, Data_im(im), caml_gr_bstore.gc,
             x, Bcvt(y) + 1 - Height_im(im),
             Width_im(im), Height_im(im),
             0, 0);
   return Val_unit;
 }
 
-value gr_draw_image(value im, value vx, value vy)
+value caml_gr_draw_image(value im, value vx, value vy)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
   int wy = Wcvt(y) + 1 - Height_im(im);
   int by = Bcvt(y) + 1 - Height_im(im);
 
-  gr_check_open();
+  caml_gr_check_open();
   if (Mask_im(im) != None) {
-    if(grremember_mode) {
-      XSetClipOrigin(grdisplay, grbstore.gc, x, by);
-      XSetClipMask(grdisplay, grbstore.gc, Mask_im(im));
+    if(caml_gr_remember_modeflag) {
+      XSetClipOrigin(caml_gr_display, caml_gr_bstore.gc, x, by);
+      XSetClipMask(caml_gr_display, caml_gr_bstore.gc, Mask_im(im));
     }
-    if(grdisplay_mode) {
-      XSetClipOrigin(grdisplay, grwindow.gc, x, wy);
-      XSetClipMask(grdisplay, grwindow.gc, Mask_im(im));
+    if(caml_gr_display_modeflag) {
+      XSetClipOrigin(caml_gr_display, caml_gr_window.gc, x, wy);
+      XSetClipMask(caml_gr_display, caml_gr_window.gc, Mask_im(im));
     }
   }
-  if(grremember_mode)
-    XCopyArea(grdisplay, Data_im(im), grbstore.win, grbstore.gc,
+  if(caml_gr_remember_modeflag)
+    XCopyArea(caml_gr_display, Data_im(im), caml_gr_bstore.win, caml_gr_bstore.gc,
               0, 0,
               Width_im(im), Height_im(im),
               x, by);
-  if(grdisplay_mode)
-    XCopyArea(grdisplay, Data_im(im), grwindow.win, grwindow.gc,
+  if(caml_gr_display_modeflag)
+    XCopyArea(caml_gr_display, Data_im(im), caml_gr_window.win, caml_gr_window.gc,
           0, 0,
           Width_im(im), Height_im(im),
           x, wy);
   if (Mask_im(im) != None) {
-    if(grremember_mode)
-      XSetClipMask(grdisplay, grbstore.gc, None);
-    if(grdisplay_mode)
-      XSetClipMask(grdisplay, grwindow.gc, None);
+    if(caml_gr_remember_modeflag)
+      XSetClipMask(caml_gr_display, caml_gr_bstore.gc, None);
+    if(caml_gr_display_modeflag)
+      XSetClipMask(caml_gr_display, caml_gr_window.gc, None);
   }
-  if(grdisplay_mode)
-    XFlush(grdisplay);
+  if(caml_gr_display_modeflag)
+    XFlush(caml_gr_display);
   return Val_unit;
 }
+
+/* eof $Id: image.c,v 1.13 2004/03/24 15:02:05 starynke Exp $ */
diff --git a/otherlibs/graph/image.h b/otherlibs/graph/image.h
index 4cfda4c2..72f41efd 100644
--- a/otherlibs/graph/image.h
+++ b/otherlibs/graph/image.h
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: image.h,v 1.7 2001/12/07 13:39:54 xleroy Exp $ */
+/* $Id: image.h,v 1.8 2004/03/24 15:02:06 starynke Exp $ */
 
 struct grimage {
   int width, height;            /* Dimensions of the image */
@@ -26,4 +26,4 @@ struct grimage {
 
 #define Transparent (-1)
 
-value gr_new_image(int w, int h);
+value caml_gr_new_image(int w, int h);
diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h
index 574c482b..86b0eca1 100644
--- a/otherlibs/graph/libgraph.h
+++ b/otherlibs/graph/libgraph.h
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: libgraph.h,v 1.21 2003/04/25 12:25:21 xleroy Exp $ */
+/* $Id: libgraph.h,v 1.23 2004/05/30 10:25:08 xleroy Exp $ */
 
 #include <stdio.h>
 #include <X11/Xlib.h>
@@ -24,30 +24,31 @@ struct canvas {
   GC gc;                        /* The associated graphics context */
 };
 
-extern Display * grdisplay;     /* The display connection */
-extern int grscreen;            /* The screen number */
-extern Colormap grcolormap;     /* The color map */
-extern struct canvas grwindow;  /* The graphics window */
-extern struct canvas grbstore;  /* The pixmap used for backing store */
-extern int grwhite, grblack;    /* Black and white pixels for X */
-extern int grbackground;        /* Background color for X 
+extern Display * caml_gr_display;     /* The display connection */
+extern int caml_gr_screen;            /* The screen number */
+extern Colormap caml_gr_colormap;     /* The color map */
+extern struct canvas caml_gr_window;  /* The graphics window */
+extern struct canvas caml_gr_bstore;  /* The pixmap used for backing store */
+extern int caml_gr_white, caml_gr_black;    /* Black and white pixels for X */
+extern int caml_gr_background;        /* Background color for X 
                                      (used for CAML color -1) */
-extern Bool grdisplay_mode;     /* Display-mode flag */
-extern Bool grremember_mode;    /* Remember-mode flag */
-extern int grx, gry;            /* Coordinates of the current point */
-extern int grcolor;             /* Current *CAML* drawing color (can be -1) */
-extern XFontStruct * grfont;    /* Current font */
-extern long grselected_events;  /* Events we are interested in */
+extern Bool caml_gr_display_modeflag;     /* Display-mode flag */
+extern Bool caml_gr_remember_modeflag;    /* Remember-mode flag */
+extern int caml_gr_x, caml_gr_y;            /* Coordinates of the current point */
+extern int caml_gr_color;             /* Current *CAML* drawing color (can be -1) */
+extern XFontStruct * caml_gr_font;    /* Current font */
+extern long caml_gr_selected_events;  /* Events we are interested in */
+extern Bool caml_gr_ignore_sigio;     /* Whether to consume events on sigio */
 
-extern Bool direct_rgb;
-extern int byte_order;
-extern int bitmap_unit;
-extern int bits_per_pixel;
+extern Bool caml_gr_direct_rgb;
+extern int caml_gr_byte_order;
+extern int caml_gr_bitmap_unit;
+extern int caml_gr_bits_per_pixel;
 
-#define Wcvt(y) (grwindow.h - 1 - (y))
-#define Bcvt(y) (grbstore.h - 1 - (y))
-#define WtoB(y) ((y) + grbstore.h - grwindow.h)
-#define BtoW(y) ((y) + grwindow.h - grbstore.h)
+#define Wcvt(y) (caml_gr_window.h - 1 - (y))
+#define Bcvt(y) (caml_gr_bstore.h - 1 - (y))
+#define WtoB(y) ((y) + caml_gr_bstore.h - caml_gr_window.h)
+#define BtoW(y) ((y) + caml_gr_window.h - caml_gr_bstore.h)
 #define min(a,b) ((a) < (b) ? (a) : (b))
 #define max(a,b) ((a) > (b) ? (a) : (b))
 
@@ -74,11 +75,11 @@ extern int bits_per_pixel;
 #endif
 #endif
 
-extern void gr_fail(char *fmt, char *arg);
-extern void gr_check_open(void);
-extern unsigned long gr_pixel_rgb(int rgb);
-extern int gr_rgb_pixel(long unsigned int pixel);
-extern void gr_handle_event(XEvent *e);
-extern void gr_init_color_cache(void);
-extern void gr_init_direct_rgb_to_pixel(void);
-extern value id_of_window( Window w );
+extern void caml_gr_fail(char *fmt, char *arg);
+extern void caml_gr_check_open(void);
+extern unsigned long caml_gr_pixel_rgb(int rgb);
+extern int caml_gr_rgb_pixel(long unsigned int pixel);
+extern void caml_gr_handle_event(XEvent *e);
+extern void caml_gr_init_color_cache(void);
+extern void caml_gr_init_direct_rgb_to_pixel(void);
+extern value caml_gr_id_of_window( Window w );
diff --git a/otherlibs/graph/make_img.c b/otherlibs/graph/make_img.c
index 1f1104bf..a68773a5 100644
--- a/otherlibs/graph/make_img.c
+++ b/otherlibs/graph/make_img.c
@@ -11,13 +11,13 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: make_img.c,v 1.12 2001/12/07 13:39:54 xleroy Exp $ */
+/* $Id: make_img.c,v 1.13 2004/03/24 15:02:05 starynke Exp $ */
 
 #include "libgraph.h"
 #include "image.h"
 #include <memory.h>
 
-value gr_make_image(value m)
+value caml_gr_make_image(value m)
 {
   int width, height;
   value im;
@@ -28,20 +28,20 @@ value gr_make_image(value m)
   value line;
   GC gc;
 
-  gr_check_open();
+  caml_gr_check_open();
   height = Wosize_val(m);
-  if (height == 0) return gr_new_image(0, 0);
+  if (height == 0) return caml_gr_new_image(0, 0);
   width = Wosize_val(Field(m, 0));
   for (i = 1; i < height; i++)
     if (Wosize_val(Field(m, i)) != width)
-      gr_fail("make_image: lines of different lengths", NULL);
+      caml_gr_fail("make_image: lines of different lengths", NULL);
 
   /* Build an XImage for the data part of the image */
   idata =
-    XCreateImage(grdisplay, DefaultVisual(grdisplay, grscreen),
-                 XDefaultDepth(grdisplay, grscreen),
+    XCreateImage(caml_gr_display, DefaultVisual(caml_gr_display, caml_gr_screen),
+                 XDefaultDepth(caml_gr_display, caml_gr_screen),
                  ZPixmap, 0, NULL, width, height,
-                 BitmapPad(grdisplay), 0);
+                 BitmapPad(caml_gr_display), 0);
 
   bdata = (char *) stat_alloc(height * idata->bytes_per_line);
   idata->data = bdata;
@@ -52,7 +52,7 @@ value gr_make_image(value m)
     for (j = 0; j < width; j++) {
       rgb = Int_val(Field(line, j));
       if (rgb == Transparent) { has_transp = True; rgb = 0; }
-      XPutPixel(idata, j, i, gr_pixel_rgb(rgb));
+      XPutPixel(idata, j, i, caml_gr_pixel_rgb(rgb));
     }
   }
 
@@ -60,9 +60,9 @@ value gr_make_image(value m)
      build an XImage for the mask part of the image */
   if (has_transp) {
     imask =
-      XCreateImage(grdisplay, DefaultVisual(grdisplay, grscreen),
+      XCreateImage(caml_gr_display, DefaultVisual(caml_gr_display, caml_gr_screen),
                    1, ZPixmap, 0, NULL, width, height,
-                   BitmapPad(grdisplay), 0);
+                   BitmapPad(caml_gr_display), 0);
     bmask = (char *) stat_alloc(height * imask->bytes_per_line);
     imask->data = bmask;
 
@@ -78,18 +78,18 @@ value gr_make_image(value m)
   }
 
   /* Allocate the image and store the XImages into the Pixmaps */
-  im = gr_new_image(width, height);
-  gc = XCreateGC(grdisplay, Data_im(im), 0, NULL);
-  XPutImage(grdisplay, Data_im(im), gc, idata, 0, 0, 0, 0, width, height);
+  im = caml_gr_new_image(width, height);
+  gc = XCreateGC(caml_gr_display, Data_im(im), 0, NULL);
+  XPutImage(caml_gr_display, Data_im(im), gc, idata, 0, 0, 0, 0, width, height);
   XDestroyImage(idata);
-  XFreeGC(grdisplay, gc);
+  XFreeGC(caml_gr_display, gc);
   if (has_transp) {
-    Mask_im(im) = XCreatePixmap(grdisplay, grwindow.win, width, height, 1);
-    gc = XCreateGC(grdisplay, Mask_im(im), 0, NULL);
-    XPutImage(grdisplay, Mask_im(im), gc, imask, 0, 0, 0, 0, width, height);
+    Mask_im(im) = XCreatePixmap(caml_gr_display, caml_gr_window.win, width, height, 1);
+    gc = XCreateGC(caml_gr_display, Mask_im(im), 0, NULL);
+    XPutImage(caml_gr_display, Mask_im(im), gc, imask, 0, 0, 0, 0, width, height);
     XDestroyImage(imask);
-    XFreeGC(grdisplay, gc);
+    XFreeGC(caml_gr_display, gc);
   }
-  XFlush(grdisplay);
+  XFlush(caml_gr_display);
   return im;
 }
diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c
index 606679f4..d829704f 100644
--- a/otherlibs/graph/open.c
+++ b/otherlibs/graph/open.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: open.c,v 1.29 2003/04/25 12:25:21 xleroy Exp $ */
+/* $Id: open.c,v 1.32 2004/05/30 10:25:08 xleroy Exp $ */
 
 #include <string.h>
 #include <fcntl.h>
@@ -28,26 +28,27 @@
 #include <sys/time.h>
 #endif
 
-Display * grdisplay = NULL;
-int grscreen;
-Colormap grcolormap;
-int grwhite, grblack, grbackground;
-struct canvas grwindow;
-struct canvas grbstore;
-Bool grdisplay_mode;
-Bool grremember_mode;
-int grx, gry;
-int grcolor;
-extern XFontStruct * grfont;
-long grselected_events;
-static Bool gr_initialized = False;
+Display * caml_gr_display = NULL;
+int caml_gr_screen;
+Colormap caml_gr_colormap;
+int caml_gr_white, caml_gr_black, caml_gr_background;
+struct canvas caml_gr_window;
+struct canvas caml_gr_bstore;
+Bool caml_gr_display_modeflag;
+Bool caml_gr_remember_modeflag;
+int caml_gr_x, caml_gr_y;
+int caml_gr_color;
+extern XFontStruct * caml_gr_font;
+long caml_gr_selected_events;
+Bool caml_gr_ignore_sigio = False;
+static Bool caml_gr_initialized = False;
 static char * window_name = NULL;
 
-static int gr_error_handler(Display *display, XErrorEvent *error);
-static int gr_ioerror_handler(Display *display);
-value gr_clear_graph(void);
+static int caml_gr_error_handler(Display *display, XErrorEvent *error);
+static int caml_gr_ioerror_handler(Display *display);
+value caml_gr_clear_graph(void);
 
-value gr_open_graph(value arg)
+value caml_gr_open_graph(value arg)
 {
   char display_name[256], geometry_spec[64];
   char * p, * q;
@@ -57,8 +58,8 @@ value gr_open_graph(value arg)
   int x, y, w, h;
   XWindowAttributes attributes;
 
-  if (gr_initialized) {
-    gr_clear_graph();
+  if (caml_gr_initialized) {
+    caml_gr_clear_graph();
   } else {
 
     /* Parse the argument */
@@ -71,20 +72,20 @@ value gr_open_graph(value arg)
     *q = 0;
 
     /* Open the display */
-    if (grdisplay == NULL) {
-      grdisplay = XOpenDisplay(display_name);
-      if (grdisplay == NULL)
-        gr_fail("Cannot open display %s", XDisplayName(display_name));
-      grscreen = DefaultScreen(grdisplay);
-      grblack = BlackPixel(grdisplay, grscreen);
-      grwhite = WhitePixel(grdisplay, grscreen);
-      grbackground = grwhite;
-      grcolormap = DefaultColormap(grdisplay, grscreen);
+    if (caml_gr_display == NULL) {
+      caml_gr_display = XOpenDisplay(display_name);
+      if (caml_gr_display == NULL)
+        caml_gr_fail("Cannot open display %s", XDisplayName(display_name));
+      caml_gr_screen = DefaultScreen(caml_gr_display);
+      caml_gr_black = BlackPixel(caml_gr_display, caml_gr_screen);
+      caml_gr_white = WhitePixel(caml_gr_display, caml_gr_screen);
+      caml_gr_background = caml_gr_white;
+      caml_gr_colormap = DefaultColormap(caml_gr_display, caml_gr_screen);
     }
 
     /* Set up the error handlers */
-    XSetErrorHandler(gr_error_handler);
-    XSetIOErrorHandler(gr_ioerror_handler);
+    XSetErrorHandler(caml_gr_error_handler);
+    XSetIOErrorHandler(caml_gr_ioerror_handler);
 
     /* Parse the geometry specification */
     hints.x = 0;
@@ -94,7 +95,7 @@ value gr_open_graph(value arg)
     hints.flags = PPosition | PSize;
     hints.win_gravity = 0;
 
-    ret = XWMGeometry(grdisplay, grscreen, geometry_spec, "", BORDER_WIDTH,
+    ret = XWMGeometry(caml_gr_display, caml_gr_screen, geometry_spec, "", BORDER_WIDTH,
                       &hints, &x, &y, &w, &h, &hints.win_gravity);
     if (ret & (XValue | YValue)) {
       hints.x = x; hints.y = y; hints.flags |= USPosition;
@@ -104,58 +105,59 @@ value gr_open_graph(value arg)
     }
 
     /* Initial drawing color is black */
-    grcolor = 0; /* CAML COLOR */
+    caml_gr_color = 0; /* CAML COLOR */
 
     /* Create the on-screen window */
-    grwindow.w = hints.width;
-    grwindow.h = hints.height;
-    grwindow.win =
-      XCreateSimpleWindow(grdisplay, DefaultRootWindow(grdisplay),
+    caml_gr_window.w = hints.width;
+    caml_gr_window.h = hints.height;
+    caml_gr_window.win =
+      XCreateSimpleWindow(caml_gr_display, DefaultRootWindow(caml_gr_display),
                           hints.x, hints.y, hints.width, hints.height,
-                          BORDER_WIDTH, grblack, grbackground);
+                          BORDER_WIDTH, caml_gr_black, caml_gr_background);
     p = window_name;
     if (p == NULL) p = DEFAULT_WINDOW_NAME;
-    XSetStandardProperties(grdisplay, grwindow.win, p, p,
+    /* What not use XSetWMProperties? */
+    XSetStandardProperties(caml_gr_display, caml_gr_window.win, p, p,
                            None, NULL, 0, &hints);
-    grwindow.gc = XCreateGC(grdisplay, grwindow.win, 0, NULL);
-    XSetBackground(grdisplay, grwindow.gc, grbackground);
-    XSetForeground(grdisplay, grwindow.gc, grblack);
+    caml_gr_window.gc = XCreateGC(caml_gr_display, caml_gr_window.win, 0, NULL);
+    XSetBackground(caml_gr_display, caml_gr_window.gc, caml_gr_background);
+    XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_black);
 
     /* Require exposure, resize and keyboard events */
-    grselected_events = DEFAULT_SELECTED_EVENTS;
-    XSelectInput(grdisplay, grwindow.win, grselected_events);
+    caml_gr_selected_events = DEFAULT_SELECTED_EVENTS;
+    XSelectInput(caml_gr_display, caml_gr_window.win, caml_gr_selected_events);
 
     /* Map the window on the screen and wait for the first Expose event */
-    XMapWindow(grdisplay, grwindow.win);
-    do { XNextEvent(grdisplay, &event); } while (event.type != Expose);
+    XMapWindow(caml_gr_display, caml_gr_window.win);
+    do { XNextEvent(caml_gr_display, &event); } while (event.type != Expose);
 
     /* Get the actual window dimensions */
-    XGetWindowAttributes(grdisplay, grwindow.win, &attributes);
-    grwindow.w = attributes.width;
-    grwindow.h = attributes.height;
+    XGetWindowAttributes(caml_gr_display, caml_gr_window.win, &attributes);
+    caml_gr_window.w = attributes.width;
+    caml_gr_window.h = attributes.height;
 
     /* Create the pixmap used for backing store */
-    grbstore.w = grwindow.w;
-    grbstore.h = grwindow.h;
-    grbstore.win =
-      XCreatePixmap(grdisplay, grwindow.win, grbstore.w, grbstore.h,
-                    XDefaultDepth(grdisplay, grscreen));
-    grbstore.gc = XCreateGC(grdisplay, grbstore.win, 0, NULL);
-    XSetBackground(grdisplay, grbstore.gc, grbackground);
+    caml_gr_bstore.w = caml_gr_window.w;
+    caml_gr_bstore.h = caml_gr_window.h;
+    caml_gr_bstore.win =
+      XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w, caml_gr_bstore.h,
+                    XDefaultDepth(caml_gr_display, caml_gr_screen));
+    caml_gr_bstore.gc = XCreateGC(caml_gr_display, caml_gr_bstore.win, 0, NULL);
+    XSetBackground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background);
 
     /* Clear the pixmap */
-    XSetForeground(grdisplay, grbstore.gc, grbackground);
-    XFillRectangle(grdisplay, grbstore.win, grbstore.gc,
-                   0, 0, grbstore.w, grbstore.h);
-    XSetForeground(grdisplay, grbstore.gc, grblack);
+    XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background);
+    XFillRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc,
+                   0, 0, caml_gr_bstore.w, caml_gr_bstore.h);
+    XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_black);
 
     /* Set the display and remember modes on */
-    grdisplay_mode = True ;
-    grremember_mode = True ;
+    caml_gr_display_modeflag = True ;
+    caml_gr_remember_modeflag = True ;
 
     /* The global data structures are now correctly initialized.
-       In particular, gr_sigio_handler can now handle events safely. */
-    gr_initialized = True;
+       In particular, caml_gr_sigio_handler can now handle events safely. */
+    caml_gr_initialized = True;
 
     /* If possible, request that system calls be restarted after
        the EVENT_SIGNAL signal. */
@@ -172,9 +174,9 @@ value gr_open_graph(value arg)
 #ifdef USE_ASYNC_IO
     /* If BSD-style asynchronous I/O are supported:
        arrange for I/O on the connection to trigger the SIGIO signal */
-    ret = fcntl(ConnectionNumber(grdisplay), F_GETFL, 0);
-    fcntl(ConnectionNumber(grdisplay), F_SETFL, ret | FASYNC);
-    fcntl(ConnectionNumber(grdisplay), F_SETOWN, getpid());
+    ret = fcntl(ConnectionNumber(caml_gr_display), F_GETFL, 0);
+    fcntl(ConnectionNumber(caml_gr_display), F_SETFL, ret | FASYNC);
+    fcntl(ConnectionNumber(caml_gr_display), F_SETOWN, getpid());
 #endif
   }
 #ifdef USE_INTERVAL_TIMER
@@ -193,35 +195,35 @@ value gr_open_graph(value arg)
   alarm(1);
 #endif
   /* Position the current point at origin */
-  grx = 0;
-  gry = 0;
+  caml_gr_x = 0;
+  caml_gr_y = 0;
   /* Reset the color cache */
-  gr_init_color_cache();
-  gr_init_direct_rgb_to_pixel();
+  caml_gr_init_color_cache();
+  caml_gr_init_direct_rgb_to_pixel();
   return Val_unit;
 }
 
-value gr_close_graph(void)
+value caml_gr_close_graph(void)
 {
-  if (gr_initialized) {
+  if (caml_gr_initialized) {
 #ifdef USE_INTERVAL_TIMER
     struct itimerval it;
     it.it_value.tv_sec = 0;
     it.it_value.tv_usec = 0;
     setitimer(ITIMER_REAL, &it, NULL);
 #endif
-    gr_initialized = False;
-    if (grfont != NULL) { XFreeFont(grdisplay, grfont); grfont = NULL; }
-    XFreeGC(grdisplay, grwindow.gc);
-    XDestroyWindow(grdisplay, grwindow.win);
-    XFreeGC(grdisplay, grbstore.gc);
-    XFreePixmap(grdisplay, grbstore.win);
-    XFlush(grdisplay);
+    caml_gr_initialized = False;
+    if (caml_gr_font != NULL) { XFreeFont(caml_gr_display, caml_gr_font); caml_gr_font = NULL; }
+    XFreeGC(caml_gr_display, caml_gr_window.gc);
+    XDestroyWindow(caml_gr_display, caml_gr_window.win);
+    XFreeGC(caml_gr_display, caml_gr_bstore.gc);
+    XFreePixmap(caml_gr_display, caml_gr_bstore.win);
+    XFlush(caml_gr_display);
   }
   return Val_unit;
 }
 
-value id_of_window(Window win)
+value caml_gr_id_of_window(Window win)
 {
   char tmp[256];
 
@@ -229,98 +231,98 @@ value id_of_window(Window win)
   return copy_string( tmp );
 }
 
-value gr_window_id(void)
+value caml_gr_window_id(void)
 {
-  gr_check_open();
-  return id_of_window(grwindow.win);
+  caml_gr_check_open();
+  return caml_gr_id_of_window(caml_gr_window.win);
 }
 
-value gr_set_window_title(value n)
+value caml_gr_set_window_title(value n)
 {
   if (window_name != NULL) stat_free(window_name);
-  window_name = stat_alloc(strlen(String_val(n)));
+  window_name = stat_alloc(strlen(String_val(n))+1);
   strcpy(window_name, String_val(n));
-  if (gr_initialized) {
-    XStoreName(grdisplay, grwindow.win, window_name);
-    XSetIconName(grdisplay, grwindow.win, window_name);
-    XFlush(grdisplay);
+  if (caml_gr_initialized) {
+    XStoreName(caml_gr_display, caml_gr_window.win, window_name);
+    XSetIconName(caml_gr_display, caml_gr_window.win, window_name);
+    XFlush(caml_gr_display);
   }
   return Val_unit;
 }
 
-value gr_clear_graph(void)
+value caml_gr_clear_graph(void)
 {
-  gr_check_open();
-  if(grremember_mode) {
-    XSetForeground(grdisplay, grbstore.gc, grwhite);
-    XFillRectangle(grdisplay, grbstore.win, grbstore.gc,
-                   0, 0, grbstore.w, grbstore.h);
-    XSetForeground(grdisplay, grbstore.gc, grcolor);
+  caml_gr_check_open();
+  if(caml_gr_remember_modeflag) {
+    XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_white);
+    XFillRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc,
+                   0, 0, caml_gr_bstore.w, caml_gr_bstore.h);
+    XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_color);
   }
-  if(grdisplay_mode) {
-    XSetForeground(grdisplay, grwindow.gc, grwhite);
-    XFillRectangle(grdisplay, grwindow.win, grwindow.gc,
-                   0, 0, grwindow.w, grwindow.h);
-    XSetForeground(grdisplay, grwindow.gc, grcolor);
-    XFlush(grdisplay);
+  if(caml_gr_display_modeflag) {
+    XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_white);
+    XFillRectangle(caml_gr_display, caml_gr_window.win, caml_gr_window.gc,
+                   0, 0, caml_gr_window.w, caml_gr_window.h);
+    XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_color);
+    XFlush(caml_gr_display);
   }
-  gr_init_color_cache();
-  gr_init_direct_rgb_to_pixel();
+  caml_gr_init_color_cache();
+  caml_gr_init_direct_rgb_to_pixel();
   return Val_unit;
 }
 
-value gr_size_x(void)
+value caml_gr_size_x(void)
 {
-  gr_check_open();
-  return Val_int(grwindow.w);
+  caml_gr_check_open();
+  return Val_int(caml_gr_window.w);
 }
 
-value gr_size_y(void)
+value caml_gr_size_y(void)
 {
-  gr_check_open();
-  return Val_int(grwindow.h);
+  caml_gr_check_open();
+  return Val_int(caml_gr_window.h);
 }
 
-value gr_synchronize(void)
+value caml_gr_synchronize(void)
 {
-  gr_check_open();
-  XCopyArea(grdisplay, grbstore.win, grwindow.win, grwindow.gc,
-            0, grbstore.h - grwindow.h,
-            grwindow.w, grwindow.h,
+  caml_gr_check_open();
+  XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, caml_gr_window.gc,
+            0, caml_gr_bstore.h - caml_gr_window.h,
+            caml_gr_window.w, caml_gr_window.h,
             0, 0);
-  XFlush(grdisplay);
+  XFlush(caml_gr_display);
   return Val_unit ;
 }
 
-value gr_display_mode(value flag)
+value caml_gr_display_mode(value flag)
 {
-  grdisplay_mode = Bool_val (flag);
+  caml_gr_display_modeflag = Bool_val (flag);
   return Val_unit ;
 }
 
-value gr_remember_mode(value flag)
+value caml_gr_remember_mode(value flag)
 {
-  grremember_mode = Bool_val(flag);
+  caml_gr_remember_modeflag = Bool_val(flag);
   return Val_unit ;
 }
 
-/* The gr_sigio_handler is called via the signal machinery in the bytecode
+/* The caml_gr_sigio_handler is called via the signal machinery in the bytecode
    interpreter. The signal system ensures that this function will be
    called either between two bytecode instructions, or during a blocking
    primitive. In either case, not in the middle of an Xlib call. */
 
-value gr_sigio_signal(value unit)
+value caml_gr_sigio_signal(value unit)
 {
   return Val_int(EVENT_SIGNAL);
 }
 
-value gr_sigio_handler(void)
+value caml_gr_sigio_handler(void)
 {
   XEvent grevent;
 
-  if (gr_initialized) {
-    while (XCheckMaskEvent(grdisplay, -1 /*all events*/, &grevent)) {
-      gr_handle_event(&grevent);
+  if (caml_gr_initialized && !caml_gr_ignore_sigio) {
+    while (XCheckMaskEvent(caml_gr_display, -1 /*all events*/, &grevent)) {
+      caml_gr_handle_event(&grevent);
     }
   }
 #ifdef USE_ALARM
@@ -333,7 +335,7 @@ value gr_sigio_handler(void)
 
 static value * graphic_failure_exn = NULL;
 
-void gr_fail(char *fmt, char *arg)
+void caml_gr_fail(char *fmt, char *arg)
 {
   char buffer[1024];
 
@@ -346,21 +348,21 @@ void gr_fail(char *fmt, char *arg)
   raise_with_string(*graphic_failure_exn, buffer);
 }
 
-void gr_check_open(void)
+void caml_gr_check_open(void)
 {
-  if (!gr_initialized) gr_fail("graphic screen not opened", NULL);
+  if (!caml_gr_initialized) caml_gr_fail("graphic screen not opened", NULL);
 }
 
-static int gr_error_handler(Display *display, XErrorEvent *error)
+static int caml_gr_error_handler(Display *display, XErrorEvent *error)
 {
   char errmsg[512];
   XGetErrorText(error->display, error->error_code, errmsg, sizeof(errmsg));
-  gr_fail("Xlib error: %s", errmsg);
+  caml_gr_fail("Xlib error: %s", errmsg);
   return 0;
 }
 
-static int gr_ioerror_handler(Display *display)
+static int caml_gr_ioerror_handler(Display *display)
 {
-  gr_fail("fatal I/O error", NULL);
+  caml_gr_fail("fatal I/O error", NULL);
   return 0;
 }
diff --git a/otherlibs/graph/point_col.c b/otherlibs/graph/point_col.c
index f2d8ca49..a0f4a96b 100644
--- a/otherlibs/graph/point_col.c
+++ b/otherlibs/graph/point_col.c
@@ -11,20 +11,20 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: point_col.c,v 1.7 2001/12/07 13:39:55 xleroy Exp $ */
+/* $Id: point_col.c,v 1.8 2004/03/24 15:02:05 starynke Exp $ */
 
 #include "libgraph.h"
 
-value gr_point_color(value vx, value vy)
+value caml_gr_point_color(value vx, value vy)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
   XImage * im;
   int rgb;
 
-  gr_check_open();
-  im = XGetImage(grdisplay, grbstore.win, x, Bcvt(y), 1, 1, (-1), ZPixmap);
-  rgb = gr_rgb_pixel(XGetPixel(im, 0, 0));
+  caml_gr_check_open();
+  im = XGetImage(caml_gr_display, caml_gr_bstore.win, x, Bcvt(y), 1, 1, (-1), ZPixmap);
+  rgb = caml_gr_rgb_pixel(XGetPixel(im, 0, 0));
   XDestroyImage(im);
   return Val_int(rgb);
 }
diff --git a/otherlibs/graph/sound.c b/otherlibs/graph/sound.c
index 76e43007..f032d953 100644
--- a/otherlibs/graph/sound.c
+++ b/otherlibs/graph/sound.c
@@ -11,24 +11,24 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: sound.c,v 1.8 2001/12/07 13:39:55 xleroy Exp $ */
+/* $Id: sound.c,v 1.9 2004/03/24 15:02:05 starynke Exp $ */
 
 #include "libgraph.h"
 
-value gr_sound(value vfreq, value vdur)
+value caml_gr_sound(value vfreq, value vdur)
 {
   XKeyboardControl kbdcontrol;
 
-  gr_check_open();
+  caml_gr_check_open();
   kbdcontrol.bell_pitch = Int_val(vfreq);
   kbdcontrol.bell_duration = Int_val(vdur);
-  XChangeKeyboardControl(grdisplay, KBBellPitch | KBBellDuration,
+  XChangeKeyboardControl(caml_gr_display, KBBellPitch | KBBellDuration,
                          &kbdcontrol);
-  XBell(grdisplay, 0);
+  XBell(caml_gr_display, 0);
   kbdcontrol.bell_pitch = -1;   /* restore default value */
   kbdcontrol.bell_duration = -1; /* restore default value */
-  XChangeKeyboardControl(grdisplay, KBBellPitch | KBBellDuration,
+  XChangeKeyboardControl(caml_gr_display, KBBellPitch | KBBellDuration,
                          &kbdcontrol);
-  XFlush(grdisplay);
+  XFlush(caml_gr_display);
   return Val_unit;
 }
diff --git a/otherlibs/graph/subwindow.c b/otherlibs/graph/subwindow.c
index 4cd5e57c..7ecaa85a 100644
--- a/otherlibs/graph/subwindow.c
+++ b/otherlibs/graph/subwindow.c
@@ -11,11 +11,11 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: subwindow.c,v 1.5 2002/05/07 07:41:09 weis Exp $ */
+/* $Id: subwindow.c,v 1.6 2004/03/24 15:02:05 starynke Exp $ */
 
 #include "libgraph.h"
 
-value gr_open_subwindow(value vx, value vy, value width, value height)
+value caml_gr_open_subwindow(value vx, value vy, value width, value height)
 {
   Window win;
 
@@ -24,22 +24,22 @@ value gr_open_subwindow(value vx, value vy, value width, value height)
   int x = Int_val(vx);
   int y = Int_val(vy);
 
-  gr_check_open();
-  win = XCreateSimpleWindow(grdisplay, grwindow.win,
+  caml_gr_check_open();
+  win = XCreateSimpleWindow(caml_gr_display, caml_gr_window.win,
                             x, Wcvt(y + h), w, h,
-                            0, grblack, grbackground);
-  XMapWindow(grdisplay, win);
-  XFlush(grdisplay);
-  return (id_of_window (win));
+                            0, caml_gr_black, caml_gr_background);
+  XMapWindow(caml_gr_display, win);
+  XFlush(caml_gr_display);
+  return (caml_gr_id_of_window (win));
 }
 
-value gr_close_subwindow(value wid)
+value caml_gr_close_subwindow(value wid)
 {
   Window win;
 
-  gr_check_open();
+  caml_gr_check_open();
   sscanf( String_val(wid), "%lu", (unsigned long *)(&win) );
-  XDestroyWindow(grdisplay, win);
-  XFlush(grdisplay);
+  XDestroyWindow(caml_gr_display, win);
+  XFlush(caml_gr_display);
   return Val_unit;
 }
diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c
index 9914f596..9e00f0f6 100644
--- a/otherlibs/graph/text.c
+++ b/otherlibs/graph/text.c
@@ -11,74 +11,74 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: text.c,v 1.14 2001/12/07 13:39:55 xleroy Exp $ */
+/* $Id: text.c,v 1.15 2004/03/24 15:02:06 starynke Exp $ */
 
 #include "libgraph.h"
 #include <alloc.h>
 
-XFontStruct * grfont = NULL;
+XFontStruct * caml_gr_font = NULL;
 
-static void gr_font(char *fontname)
+static void caml_gr_get_font(char *fontname)
 {
-  XFontStruct * font = XLoadQueryFont(grdisplay, fontname);
-  if (font == NULL) gr_fail("cannot find font %s", fontname);
-  if (grfont != NULL) XFreeFont(grdisplay, grfont);
-  grfont = font;
-  XSetFont(grdisplay, grwindow.gc, grfont->fid);
-  XSetFont(grdisplay, grbstore.gc, grfont->fid);
+  XFontStruct * font = XLoadQueryFont(caml_gr_display, fontname);
+  if (font == NULL) caml_gr_fail("cannot find font %s", fontname);
+  if (caml_gr_font != NULL) XFreeFont(caml_gr_display, caml_gr_font);
+  caml_gr_font = font;
+  XSetFont(caml_gr_display, caml_gr_window.gc, caml_gr_font->fid);
+  XSetFont(caml_gr_display, caml_gr_bstore.gc, caml_gr_font->fid);
 }
 
-value gr_set_font(value fontname)
+value caml_gr_set_font(value fontname)
 {
-  gr_check_open();
-  gr_font(String_val(fontname));
+  caml_gr_check_open();
+  caml_gr_get_font(String_val(fontname));
   return Val_unit;
 }
 
-value gr_set_text_size (value sz)
+value caml_gr_set_text_size (value sz)
 {
   return Val_unit;
 }
 
-static void gr_draw_text(char *txt, int len)
+static void caml_gr_draw_text(char *txt, int len)
 {
-  if (grfont == NULL) gr_font(DEFAULT_FONT);
-  if (grremember_mode)
-    XDrawString(grdisplay, grbstore.win, grbstore.gc,
-                grx, Bcvt(gry) - grfont->descent + 1, txt, len);
-  if (grdisplay_mode) {
-    XDrawString(grdisplay, grwindow.win, grwindow.gc,
-                grx, Wcvt(gry) - grfont->descent + 1, txt, len);
-    XFlush(grdisplay);
+  if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT);
+  if (caml_gr_remember_modeflag)
+    XDrawString(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc,
+                caml_gr_x, Bcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, len);
+  if (caml_gr_display_modeflag) {
+    XDrawString(caml_gr_display, caml_gr_window.win, caml_gr_window.gc,
+                caml_gr_x, Wcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, len);
+    XFlush(caml_gr_display);
   }
-  grx += XTextWidth(grfont, txt, len);
+  caml_gr_x += XTextWidth(caml_gr_font, txt, len);
 }
 
-value gr_draw_char(value chr)
+value caml_gr_draw_char(value chr)
 {
   char str[1];
-  gr_check_open();
+  caml_gr_check_open();
   str[0] = Int_val(chr);
-  gr_draw_text(str, 1);
+  caml_gr_draw_text(str, 1);
   return Val_unit;
 }
 
-value gr_draw_string(value str)
+value caml_gr_draw_string(value str)
 {
-  gr_check_open();
-  gr_draw_text(String_val(str), string_length(str));
+  caml_gr_check_open();
+  caml_gr_draw_text(String_val(str), string_length(str));
   return Val_unit;
 }
 
-value gr_text_size(value str)
+value caml_gr_text_size(value str)
 {
   int width;
   value res;
-  gr_check_open();
-  if (grfont == NULL) gr_font(DEFAULT_FONT);
-  width = XTextWidth(grfont, String_val(str), string_length(str));
+  caml_gr_check_open();
+  if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT);
+  width = XTextWidth(caml_gr_font, String_val(str), string_length(str));
   res = alloc_small(2, 0);
   Field(res, 0) = Val_int(width);
-  Field(res, 1) = Val_int(grfont->ascent + grfont->descent);
+  Field(res, 1) = Val_int(caml_gr_font->ascent + caml_gr_font->descent);
   return res;
 }
diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src
index e011bbe3..5a34ce8e 100644
--- a/otherlibs/labltk/Widgets.src
+++ b/otherlibs/labltk/Widgets.src
@@ -186,6 +186,7 @@ type State {
    Normal ["normal"]
    Active ["active"]
    Disabled ["disabled"]
+   Hidden ["hidden"]                           % introduced in tk8.3, requested for Syndex
 }
 
 widget button {
@@ -374,9 +375,24 @@ subtype option(rectangle) {
    }
 
 % Text item configuration
+
+##ifndef CAMLTK
+% Only for Labltk. CanvasTextState is unified as State in Camltk
+type CanvasTextState { 
+   Normal ["normal"]
+   Disabled ["disabled"]
+   Hidden ["hidden"]
+}
+##endif
+
 subtype option(canvastext) {
    Anchor FillColor Font Justify
    Stipple Tags Text Width
+##ifdef CAMLTK
+   State                                       % introduced in tk8.3, requested for Syndex
+##else
+   CanvasTextState ["-state"; CanvasTextState] % introduced in tk8.3, requested for Syndex
+##endif
    }
 
 % Window item configuration
diff --git a/otherlibs/labltk/browser/dummyUnix.mli b/otherlibs/labltk/browser/dummyUnix.mli
index 2394eb2c..4d394f11 100644
--- a/otherlibs/labltk/browser/dummyUnix.mli
+++ b/otherlibs/labltk/browser/dummyUnix.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: dummyUnix.mli,v 1.3 2001/12/07 13:39:55 xleroy Exp $ *)
+(* $Id: dummyUnix.mli,v 1.4 2003/12/29 22:15:01 doligez Exp $ *)
 
 module Mutex : sig
   type t
@@ -23,5 +23,5 @@ end
 
 module Thread : sig
   type t
-  external create : ('a -> 'b) -> 'a -> t = "caml_input"
+  external create : ('a -> 'b) -> 'a -> t = "caml_ml_input"
 end
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
index 2ea2f0e4..fa543cea 100644
--- a/otherlibs/labltk/browser/searchid.ml
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: searchid.ml,v 1.21 2003/07/02 09:14:30 xleroy Exp $ *)
+(* $Id: searchid.ml,v 1.22 2004/06/12 08:55:46 xleroy Exp $ *)
 
 open StdLabels
 open Location
@@ -220,7 +220,7 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
   begin fun item -> match item with
         Tsig_value (id, vd) ->
           if matches vd.val_type then [lid_of_id id, Pvalue] else []
-      | Tsig_type (id, td) ->
+      | Tsig_type (id, td, _) ->
           if
           begin match td.type_manifest with
             None -> false
@@ -238,19 +238,19 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
           if List.exists l ~f:matches
           then [lid_of_id id, Pconstructor]
           else []
-      | Tsig_module (id, Tmty_signature sign) ->
+      | Tsig_module (id, Tmty_signature sign, _) ->
           search_type_in_signature t ~sign ~mode
             ~prefix:(prefix @ [Ident.name id])
       | Tsig_module _ -> []
       | Tsig_modtype _ -> []
-      | Tsig_class (id, cl) ->
+      | Tsig_class (id, cl, _) ->
           let self = self_type cl.cty_type in
           if matches self
           || (match cl.cty_new with None -> false | Some ty -> matches ty)
           (* || List.exists (get_fields ~prefix ~sign self)
               ~f:(fun (_,_,ty_field) -> matches ty_field) *)
           then [lid_of_id id, Pclass] else []
-      | Tsig_cltype (id, cl) ->
+      | Tsig_cltype (id, cl, _) ->
           let self = self_type cl.clty_type in
           if matches self
           (* || List.exists (get_fields ~prefix ~sign self)
@@ -354,16 +354,16 @@ let search_pattern_symbol text =
         List2.flat_map sign ~f:
           begin function
             Tsig_value (i, _) when check i -> [i, Pvalue]
-          | Tsig_type (i, _) when check i -> [i, Ptype]
+          | Tsig_type (i, _, _) when check i -> [i, Ptype]
           | Tsig_exception (i, _) when check i -> [i, Pconstructor]
-          | Tsig_module (i, _) when check i -> [i, Pmodule]
+          | Tsig_module (i, _, _) when check i -> [i, Pmodule]
           | Tsig_modtype (i, _) when check i -> [i, Pmodtype]
-          | Tsig_class (i, cl) when check i
+          | Tsig_class (i, cl, _) when check i
             || List.exists
                 (get_fields ~prefix:[modname] ~sign (self_type cl.cty_type))
                 ~f:(fun (name,_,_) -> check_match ~pattern (explode name))
             -> [i, Pclass]
-          | Tsig_cltype (i, cl) when check i
+          | Tsig_cltype (i, cl, _) when check i
             || List.exists
                 (get_fields ~prefix:[modname] ~sign (self_type cl.clty_type))
                 ~f:(fun (name,_,_) -> check_match ~pattern (explode name))
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 7f0183c0..466ad86e 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: searchpos.ml,v 1.41 2003/07/02 09:14:30 xleroy Exp $ *)
+(* $Id: searchpos.ml,v 1.44.2.1 2004/06/29 01:50:19 garrigue Exp $ *)
 
 open StdLabels
 open Support
@@ -206,8 +206,8 @@ let rec search_pos_signature l ~pos ~env =
           add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc
       | Psig_module (_, t) -> 
           search_pos_module t ~pos ~env
-      | Psig_recmodule decls -> 
-          assert false (* to be fixed *)
+      | Psig_recmodule decls ->
+          List.iter decls ~f:(fun (_, t) -> search_pos_module t ~pos ~env)
       | Psig_modtype (_, Pmodtype_manifest t) ->
           search_pos_module t ~pos ~env
       | Psig_modtype _ -> ()
@@ -290,12 +290,12 @@ let edit_source ~file ~path ~sign =
       let id, kind =
         match item with
           Tsig_value (id, _) -> id, Pvalue
-        | Tsig_type (id, _) -> id, Ptype
+        | Tsig_type (id, _, _) -> id, Ptype
         | Tsig_exception (id, _) -> id, Pconstructor
-        | Tsig_module (id, _) -> id, Pmodule
+        | Tsig_module (id, _, _) -> id, Pmodule
         | Tsig_modtype (id, _) -> id, Pmodtype
-        | Tsig_class (id, _) -> id, Pclass
-        | Tsig_cltype (id, _) -> id, Pcltype
+        | Tsig_class (id, _, _) -> id, Pclass
+        | Tsig_cltype (id, _, _) -> id, Pcltype
       in
       let prefix = List.tl (list_of_path path) and name = Ident.name id in
       let pos =
@@ -316,6 +316,8 @@ let edit_source ~file ~path ~sign =
 (* List of windows to destroy by Close All *)
 let top_widgets = ref []
 
+let dummy_item = Tsig_modtype (Ident.create "dummy", Tmodtype_abstract)
+
 let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
   let env =
     match path with None -> env
@@ -438,7 +440,7 @@ and view_module path ~env =
       !view_defined_ref (Searchid.longident_of_path path) ~env
   | modtype ->
       let id = ident_of_path path ~default:"M" in
-      view_signature_item [Tsig_module (id, modtype)] ~path ~env
+      view_signature_item [Tsig_module (id, modtype, Trec_not)] ~path ~env
 
 and view_module_id id ~env =
   let path, _ = lookup_module id env in
@@ -451,11 +453,12 @@ and view_type_decl path ~env =
         {desc = Tobject _} ->
           let clt = find_cltype path env in
           view_signature_item ~path ~env
-            [Tsig_cltype(ident_of_path path ~default:"ct", clt)]
+            [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first);
+             dummy_item; dummy_item]
       | _ -> raise Not_found
   with Not_found ->
     view_signature_item ~path ~env
-      [Tsig_type(ident_of_path path ~default:"t", td)]
+      [Tsig_type(ident_of_path path ~default:"t", td, Trec_first)]
 
 and view_type_id li ~env =
   let path, decl = lookup_type li env in
@@ -464,12 +467,14 @@ and view_type_id li ~env =
 and view_class_id li ~env =
   let path, cl = lookup_class li env in
   view_signature_item ~path ~env
-     [Tsig_class(ident_of_path path ~default:"c", cl)]
+     [Tsig_class(ident_of_path path ~default:"c", cl, Trec_first);
+      dummy_item; dummy_item; dummy_item]
 
 and view_cltype_id li ~env =
   let path, clt = lookup_cltype li env in
   view_signature_item ~path ~env
-     [Tsig_cltype(ident_of_path path ~default:"ct", clt)]
+     [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first);
+      dummy_item; dummy_item]
 
 and view_modtype_id li ~env =
   let path, td = lookup_modtype li env in
@@ -576,19 +581,19 @@ let view_type kind ~env =
       | `New path ->
           let cl = find_class path env in
           view_signature_item ~path ~env
-            [Tsig_class(ident_of_path path ~default:"c", cl)]
+            [Tsig_class(ident_of_path path ~default:"c", cl, Trec_first)]
       end
   | `Class (path, cty) ->
       let cld = { cty_params = []; cty_type = cty;
                   cty_path = path; cty_new = None } in
       view_signature_item ~path ~env
-        [Tsig_class(ident_of_path path ~default:"c", cld)]
+        [Tsig_class(ident_of_path path ~default:"c", cld, Trec_first)]
   | `Module (path, mty) ->
       match mty with
         Tmty_signature sign -> view_signature sign ~path ~env
       | modtype ->
           view_signature_item ~path ~env
-            [Tsig_module(ident_of_path path ~default:"M", mty)]
+            [Tsig_module(ident_of_path path ~default:"M", mty, Trec_not)]
 
 let view_type_menu kind ~env ~parent =
   let title =
@@ -665,7 +670,8 @@ let rec search_pos_structure ~pos str =
   | Tstr_exception _ -> ()
   | Tstr_exn_rebind(_, _) -> ()
   | Tstr_module (_, m) -> search_pos_module_expr m ~pos
-  | Tstr_recmodule bindings -> assert false (* to be fixed *)
+  | Tstr_recmodule bindings ->
+      List.iter bindings ~f:(fun (_, m) -> search_pos_module_expr m ~pos)
   | Tstr_modtype _ -> ()
   | Tstr_open _ -> ()
   | Tstr_class l ->
@@ -674,6 +680,23 @@ let rec search_pos_structure ~pos str =
   | Tstr_include (m, _) -> search_pos_module_expr m ~pos
   end
 
+and search_pos_class_structure ~pos cls =
+  List.iter cls.cl_field ~f:
+    begin function
+        Cf_inher (cl, _, _) ->
+          search_pos_class_expr cl ~pos
+      | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
+      | Cf_meth (_, exp) -> search_pos_expr exp ~pos
+      | Cf_let (_, pel, iel) ->
+          List.iter pel ~f:
+            begin fun (pat, exp) ->
+              search_pos_pat pat ~pos ~env:exp.exp_env;
+              search_pos_expr exp ~pos
+            end;
+          List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
+      | Cf_init exp -> search_pos_expr exp ~pos
+    end
+
 and search_pos_class_expr ~pos cl =
   if in_loc cl.cl_loc ~pos then begin
     begin match cl.cl_desc with
@@ -681,21 +704,7 @@ and search_pos_class_expr ~pos cl =
         add_found_str (`Class (path, cl.cl_type))
           ~env:!start_env ~loc:cl.cl_loc
     | Tclass_structure cls ->
-        List.iter cls.cl_field ~f:
-          begin function
-              Cf_inher (cl, _, _) ->
-                search_pos_class_expr cl ~pos
-            | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
-            | Cf_meth (_, exp) -> search_pos_expr exp ~pos
-            | Cf_let (_, pel, iel) ->
-                List.iter pel ~f:
-                  begin fun (pat, exp) ->
-                    search_pos_pat pat ~pos ~env:exp.exp_env;
-                    search_pos_expr exp ~pos
-                  end;
-                List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
-            | Cf_init exp -> search_pos_expr exp ~pos
-          end
+	search_pos_class_structure ~pos cls
     | Tclass_fun (pat, iel, cl, _) ->
         search_pos_pat pat ~pos ~env:pat.pat_env;
         List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos);
@@ -802,6 +811,8 @@ and search_pos_expr ~pos exp =
       search_pos_expr exp ~pos
   | Texp_lazy exp ->
       search_pos_expr exp ~pos
+  | Texp_object (cls, _, _) ->
+      	search_pos_class_structure ~pos cls
   end;
   add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
   end
diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml
index 09207a52..f61490f9 100644
--- a/otherlibs/labltk/browser/viewer.ml
+++ b/otherlibs/labltk/browser/viewer.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: viewer.ml,v 1.30 2002/08/09 10:34:44 garrigue Exp $ *)
+(* $Id: viewer.ml,v 1.31 2004/06/12 08:55:47 xleroy Exp $ *)
 
 open StdLabels
 open Tk
@@ -218,12 +218,12 @@ let search_symbol () =
 
 let ident_of_decl ~modlid = function
     Tsig_value (id, _) -> Lident (Ident.name id), Pvalue
-  | Tsig_type (id, _) -> Lident (Ident.name id), Ptype
+  | Tsig_type (id, _, _) -> Lident (Ident.name id), Ptype
   | Tsig_exception (id, _) -> Ldot (modlid, Ident.name id), Pconstructor
-  | Tsig_module (id, _) -> Lident (Ident.name id), Pmodule
+  | Tsig_module (id, _, _) -> Lident (Ident.name id), Pmodule
   | Tsig_modtype (id, _) -> Lident (Ident.name id), Pmodtype
-  | Tsig_class (id, _) -> Lident (Ident.name id), Pclass
-  | Tsig_cltype (id, _) -> Lident (Ident.name id), Pcltype
+  | Tsig_class (id, _, _) -> Lident (Ident.name id), Pclass
+  | Tsig_cltype (id, _, _) -> Lident (Ident.name id), Pcltype
 
 let view_defined ~env ?(show_all=false) modlid =
   try match lookup_module modlid env with path, Tmty_signature sign ->
diff --git a/otherlibs/labltk/browser/winmain.c b/otherlibs/labltk/browser/winmain.c
index d36f6786..4e82d1e2 100644
--- a/otherlibs/labltk/browser/winmain.c
+++ b/otherlibs/labltk/browser/winmain.c
@@ -5,13 +5,13 @@
 
 extern int __argc;
 extern char **__argv;
-extern void expand_command_line(int * argcp, char *** argvp);
+extern void caml_expand_command_line(int * argcp, char *** argvp);
 extern void caml_main (char **);
 
 int WINAPI WinMain(HINSTANCE h, HINSTANCE HPrevInstance,
                    LPSTR lpCmdLine, int nCmdShow)
 {
-  expand_command_line(&__argc, &__argv);
+  caml_expand_command_line(&__argc, &__argv);
   caml_main(__argv);
   sys_exit(Val_int(0));
   return 0;
diff --git a/otherlibs/labltk/examples_labltk/tetris.ml b/otherlibs/labltk/examples_labltk/tetris.ml
index 18655627..b9af0d1b 100644
--- a/otherlibs/labltk/examples_labltk/tetris.ml
+++ b/otherlibs/labltk/examples_labltk/tetris.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tetris.ml,v 1.2 2002/04/26 12:16:00 furuse Exp $ *)
+(* $Id: tetris.ml,v 1.4 2004/06/12 03:20:00 garrigue Exp $ *)
 
 (* A Tetris game for LablTk *)
 (* written by Jun P. Furuse *)
@@ -643,21 +643,21 @@ let _ =
     bind w ~events:[`KeyPress] ~fields:[`KeySymString] ~action:
       begin fun e -> 
         match e.ev_KeySymString with
-        | "h" ->
+        | "h"|"Left" ->
             let m = copy_block current in
             m.x <- m.x - 1;
             ignore (try_to_move m)
-        | "j" ->
+        | "j"|"Up" ->
             let m = copy_block current in
             m.d <- m.d + 1;
             if m.d = List.length m.pattern then m.d <- 0;
             ignore (try_to_move m)
-        | "k" ->
+        | "k"|"Down" ->
             let m = copy_block current in
             m.d <- m.d - 1;
             if m.d < 0 then m.d <- List.length m.pattern - 1;
             ignore (try_to_move m)
-        | "l" ->
+        | "l"|"Right" ->
             let m = copy_block current in
             m.x <- m.x + 1;
             ignore (try_to_move m)
diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c
index 59c945bf..03843195 100644
--- a/otherlibs/labltk/support/cltkEval.c
+++ b/otherlibs/labltk/support/cltkEval.c
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkEval.c,v 1.13 2003/07/10 09:18:02 xleroy Exp $ */
+/* $Id: cltkEval.c,v 1.14 2004/05/17 17:10:00 doligez Exp $ */
 
 #include <stdlib.h>
 #include <string.h>
@@ -199,7 +199,6 @@ CAMLprim value camltk_tcl_direct_eval(value v)
      */
     if (info.proc == NULL) {
       Tcl_DString buf;
-      char *string;
       Tcl_DStringInit(&buf);
       Tcl_DStringAppend(&buf, argv[0], -1);
       for (i=1; i<size; i++) {
diff --git a/otherlibs/labltk/support/cltkImg.c b/otherlibs/labltk/support/cltkImg.c
index 1debe822..445338e0 100644
--- a/otherlibs/labltk/support/cltkImg.c
+++ b/otherlibs/labltk/support/cltkImg.c
@@ -81,7 +81,6 @@ camltk_setimgdata_native (value imgname, value pixmap, value x, value y,
 {
   Tk_PhotoHandle ph;
   Tk_PhotoImageBlock pib;
-  int code;
 
 #if (TK_MAJOR_VERSION < 8)
   if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) 
diff --git a/otherlibs/labltk/tkanim/Makefile b/otherlibs/labltk/tkanim/Makefile
index 0e841da7..be7e8a7b 100644
--- a/otherlibs/labltk/tkanim/Makefile
+++ b/otherlibs/labltk/tkanim/Makefile
@@ -28,16 +28,16 @@ gifanimtest-static: all gifanimtest.cmo
 gifanimtest: all gifanimtest.cmo
 	$(CAMLC) -o $@ -I ../lib -I ../support -I ../../unix -dllpath ../support -dllpath . unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo
 
-animwish: $(TKANIM_LIB) tkAppInit.o
-	$(CC) -o $@  tkAppInit.o $(TK_LINK) $(X11_LINK) \
-		-L. -ltkanim $(LIBS)
+#animwish: $(TKANIM_LIB) tkAppInit.o
+#	$(CC) -o $@  tkAppInit.o $(TK_LINK) $(X11_LINK) \
+#		-L. -ltkanim $(LIBS)
 
 $(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
 
 $(OBJS:.cmo=.cmx): ../lib/$(LIBNAME).cmxa
 
 clean:
-	rm -f *.cm* *.o *.a dlltkanim.so animwish gifanimtest gifanimtest-static
+	rm -f *.cm* *.o *.a dlltkanim.so gifanimtest gifanimtest-static
 
 .SUFFIXES :
 .SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .o
diff --git a/otherlibs/labltk/tkanim/tkAnimGIF.c b/otherlibs/labltk/tkanim/tkAnimGIF.c
index 1beb8143..d8eb11eb 100644
--- a/otherlibs/labltk/tkanim/tkAnimGIF.c
+++ b/otherlibs/labltk/tkanim/tkAnimGIF.c
@@ -102,7 +102,6 @@ FileReadGIF(interp, f, fileName, formatString)
     char newresbuf[640];
     char *imageName;
     char *resultptr;
-    int prevpos;
     int loop = -1;
 
     if((winPtr = Tk_MainWindow(interp)) == NULL){
diff --git a/otherlibs/macosunix/.cvsignore b/otherlibs/macosunix/.cvsignore
deleted file mode 100644
index 2bbb2a16..00000000
--- a/otherlibs/macosunix/.cvsignore
+++ /dev/null
@@ -1,71 +0,0 @@
-*.x
-byterun
-config
-accept.c
-access.c
-addrofstr.c
-alarm.c
-bind.c
-chdir.c
-chmod.c
-close.c
-closedir.c
-connect.c
-cst2constr.c
-cstringv.c
-dup.c
-dup2.c
-errmsg.c
-exit.c
-fchmod.c
-fchown.c
-fcntl.c
-ftruncate.c
-getcwd.c
-getgroups.c
-gethost.c
-gethostname.c
-getpeername.c
-getproto.c
-getserv.c
-getsockname.c
-gettimeofday.c
-gmtime.c
-itimer.c
-listen.c
-lockf.c
-lseek.c
-mkdir.c
-open.c
-opendir.c
-pipe.c
-putenv.c
-read.c
-readdir.c
-readlink.c
-rename.c
-rewinddir.c
-rmdir.c
-select.c
-sendrecv.c
-setsid.c
-shutdown.c
-signals.c
-sleep.c
-socket.c
-socketaddr.c
-socketpair.c
-sockopt.c
-stat.c
-strofaddr.c
-symlink.c
-termios.c
-truncate.c
-unixsupport.c
-unlink.c
-utimes.c
-write.c
-cst2constr.h
-socketaddr.h
-unix.ml
-unix.mli
diff --git a/otherlibs/macosunix/Makefile.Mac b/otherlibs/macosunix/Makefile.Mac
deleted file mode 100644
index 9c87abe9..00000000
--- a/otherlibs/macosunix/Makefile.Mac
+++ /dev/null
@@ -1,152 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#          Damien Doligez, projet Moscova, 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.6 2002/01/20 15:12:29 doligez Exp $
-
-includepath = ":config:,:byterun:,{GUSI}include:"
-
-C = sc
-COptions = -i {includepath} -includes unix -w 30,35 {cdbgflag} -model far
-
-PPCC = mrc
-PPCCOptions = -i {includepath} -includes unix -w 30,35 {cdbgflag}
-
-CAMLC = :::boot:ocamlrun :::boot:ocamlc -I :::stdlib: -warn-error A
-
-
-# Files in this directory
-MAC_OBJS = macosunix.c.o
-
-MAC_OBJSPPC = macosunix.c.x
-
-# Files from the ::unix: directory
-UNIX_FILES = accept.c access.c addrofstr.c alarm.c bind.c ¶
-             chdir.c chmod.c close.c closedir.c ¶
-             connect.c cst2constr.c cstringv.c dup.c dup2.c ¶
-             errmsg.c exit.c ¶
-             fchmod.c fchown.c fcntl.c ftruncate.c ¶
-             getcwd.c ¶
-             getgroups.c gethost.c gethostname.c ¶
-             getpeername.c getproto.c ¶
-             getserv.c getsockname.c gettimeofday.c ¶
-             gmtime.c itimer.c listen.c lockf.c ¶
-             lseek.c mkdir.c open.c opendir.c ¶
-             pipe.c putenv.c read.c readdir.c readlink.c ¶
-             rename.c rewinddir.c rmdir.c select.c sendrecv.c ¶
-             setsid.c shutdown.c signals.c ¶
-             sleep.c socket.c socketaddr.c socketpair.c ¶
-             sockopt.c stat.c strofaddr.c symlink.c termios.c ¶
-             truncate.c unixsupport.c ¶
-             unlink.c utimes.c write.c ¶
-             ¶
-             cst2constr.h socketaddr.h ¶
-             unix.ml unix.mli
-
-UNIX_OBJS = accept.c.o access.c.o addrofstr.c.o alarm.c.o bind.c.o ¶
-             chdir.c.o chmod.c.o close.c.o closedir.c.o ¶
-             connect.c.o cst2constr.c.o cstringv.c.o dup.c.o dup2.c.o ¶
-             errmsg.c.o exit.c.o ¶
-             fchmod.c.o fchown.c.o fcntl.c.o ftruncate.c.o ¶
-             getcwd.c.o ¶
-             getgroups.c.o gethost.c.o gethostname.c.o ¶
-             getpeername.c.o getproto.c.o ¶
-             getserv.c.o getsockname.c.o gettimeofday.c.o ¶
-             gmtime.c.o itimer.c.o listen.c.o lockf.c.o ¶
-             lseek.c.o mkdir.c.o open.c.o opendir.c.o ¶
-             pipe.c.o putenv.c.o read.c.o readdir.c.o readlink.c.o ¶
-             rename.c.o rewinddir.c.o rmdir.c.o select.c.o sendrecv.c.o ¶
-             setsid.c.o shutdown.c.o signals.c.o ¶
-             sleep.c.o socket.c.o socketaddr.c.o socketpair.c.o ¶
-             sockopt.c.o stat.c.o strofaddr.c.o symlink.c.o termios.c.o ¶
-             truncate.c.o unixsupport.c.o ¶
-             unlink.c.o utimes.c.o write.c.o
-
-PPCUNIX_OBJS = accept.c.x access.c.x addrofstr.c.x alarm.c.x bind.c.x ¶
-             chdir.c.x chmod.c.x close.c.x closedir.c.x ¶
-             connect.c.x cst2constr.c.x cstringv.c.x dup.c.x dup2.c.x ¶
-             errmsg.c.x exit.c.x ¶
-             fchmod.c.x fchown.c.x fcntl.c.x ftruncate.c.x ¶
-             getcwd.c.x ¶
-             getgroups.c.x gethost.c.x gethostname.c.x ¶
-             getpeername.c.x getproto.c.x ¶
-             getserv.c.x getsockname.c.x gettimeofday.c.x ¶
-             gmtime.c.x itimer.c.x listen.c.x lockf.c.x ¶
-             lseek.c.x mkdir.c.x open.c.x opendir.c.x ¶
-             pipe.c.x putenv.c.x read.c.x readdir.c.x readlink.c.x ¶
-             rename.c.x rewinddir.c.x rmdir.c.x select.c.x sendrecv.c.x ¶
-             setsid.c.x shutdown.c.x signals.c.x ¶
-             sleep.c.x socket.c.x socketaddr.c.x socketpair.c.x ¶
-             sockopt.c.x stat.c.x strofaddr.c.x symlink.c.x termios.c.x ¶
-             truncate.c.x unixsupport.c.x ¶
-             unlink.c.x utimes.c.x write.c.x
-
-C_OBJS = {MAC_OBJS} {UNIX_OBJS}
-C_OBJSPPC = {MAC_OBJSPPC} {PPCUNIX_OBJS}
-
-CAML_OBJS = macosunix_startup.cmo unix.cmo
-
-all Ä
-    domake copy-files
-    directory :byterun:
-    domake libcamlrun.x libcamlrun.o
-    directory ::
-    domake libcamlrun-unix.x libcamlrun-unix.o unix.cma
-
-### WATCH OUT: libcamlrun.[ox] must be linked last to override getcwd
-
-libcamlrun-unix.x Ä {C_OBJSPPC} :byterun:libcamlrun.x
-    ppclink {ldbgflag} -xm library -o libcamlrun-unix.x ¶
-            {C_OBJSPPC} :byterun:libcamlrun.x
-
-libcamlrun-unix.o Ä {C_OBJS} :byterun:libcamlrun.o
-    lib {ldbgflag} -o libcamlrun-unix.o {C_OBJS} :byterun:libcamlrun.o
-
-copy-files Ä $OutOfDate
-    directory ::unix:
-    duplicate -y {UNIX_FILES} ::macosunix:
-    directory ::macosunix:
-    newfolder :byterun || set status 0
-    duplicate -y :::byterun:Å.[ach] :::byterun:Makefile.Mac.depend :byterun:
-    begin
-      echo 'ocamlgusiflag = -d macintosh_GUSI -includes unix -i "{GUSI}include:"'
-      catenate :::byterun:Makefile.Mac
-    end > :byterun:Makefile.Mac
-    duplicate -y :::config: :
-
-unix.cma Ä {CAML_OBJS}
-    {CAMLC} -a -linkall -o unix.cma {CAML_OBJS}
-
-partialclean Ä
-    delete -i Å.cmÅ || set status 0
-
-clean Ä partialclean
-    delete -i Å.[xo] || set status 0
-    delete -i -y :byterun :config
-    delete -i {UNIX_FILES}
-
-install Ä
-    duplicate -y libcamlrun-unix.o libcamlrun-unix.x unix.cmi unix.cma ¶
-              "{LIBDIR}"
-
-.cmi Ä .mli
-    {CAMLC} -c {COMPFLAGS} "{depdir}{default}.mli"
-
-.cmo Ä .ml
-    {CAMLC} -c {COMPFLAGS} "{depdir}{default}.ml"
-
-depend Ä copy-files
-    begin
-      MakeDepend -w -objext .x Å.c
-      MakeDepend -w Å.c
-      :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml
-    end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/otherlibs/macosunix/Makefile.Mac.depend b/otherlibs/macosunix/Makefile.Mac.depend
deleted file mode 100644
index bf3f0f8f..00000000
--- a/otherlibs/macosunix/Makefile.Mac.depend
+++ /dev/null
@@ -1,872 +0,0 @@
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 23:43:09 on 27 fŽv 2001 by MakeDepend
-
-:accept.c.x Ä  ¶
- :accept.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:access.c.x Ä  ¶
- :access.c ¶
- :unixsupport.h
-
-:addrofstr.c.x Ä  ¶
- :addrofstr.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:alarm.c.x Ä  ¶
- :alarm.c ¶
- :unixsupport.h
-
-:bind.c.x Ä  ¶
- :bind.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:chdir.c.x Ä  ¶
- :chdir.c ¶
- :unixsupport.h
-
-:chmod.c.x Ä  ¶
- :chmod.c ¶
- :unixsupport.h
-
-:close.c.x Ä  ¶
- :close.c ¶
- :unixsupport.h
-
-:closedir.c.x Ä  ¶
- :closedir.c ¶
- :unixsupport.h
-
-:connect.c.x Ä  ¶
- :connect.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:cst2constr.c.x Ä  ¶
- :cst2constr.c ¶
- :cst2constr.h
-
-:cstringv.c.x Ä  ¶
- :cstringv.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:dup.c.x Ä  ¶
- :dup.c ¶
- :unixsupport.h
-
-:dup2.c.x Ä  ¶
- :dup2.c ¶
- :unixsupport.h
-
-:errmsg.c.x Ä  ¶
- :errmsg.c ¶
- "{CIncludes}"errno.h
-
-:exit.c.x Ä  ¶
- :exit.c ¶
- :unixsupport.h
-
-:fchmod.c.x Ä  ¶
- :fchmod.c ¶
- :unixsupport.h
-
-:fchown.c.x Ä  ¶
- :fchown.c ¶
- :unixsupport.h
-
-:fcntl.c.x Ä  ¶
- :fcntl.c ¶
- :unixsupport.h ¶
- "{CIncludes}"fcntl.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:ftruncate.c.x Ä  ¶
- :ftruncate.c ¶
- :unixsupport.h
-
-:getcwd.c.x Ä  ¶
- :getcwd.c ¶
- :unixsupport.h
-
-:getgroups.c.x Ä  ¶
- :getgroups.c ¶
- "{CIncludes}"limits.h ¶
- :unixsupport.h
-
-:gethost.c.x Ä  ¶
- :gethost.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:gethostname.c.x Ä  ¶
- :gethostname.c ¶
- :unixsupport.h
-
-:getpeername.c.x Ä  ¶
- :getpeername.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:getproto.c.x Ä  ¶
- :getproto.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:getserv.c.x Ä  ¶
- :getserv.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:getsockname.c.x Ä  ¶
- :getsockname.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:gettimeofday.c.x Ä  ¶
- :gettimeofday.c ¶
- :unixsupport.h
-
-:gmtime.c.x Ä  ¶
- :gmtime.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"time.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:itimer.c.x Ä  ¶
- :itimer.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:listen.c.x Ä  ¶
- :listen.c ¶
- :unixsupport.h
-
-:lockf.c.x Ä  ¶
- :lockf.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"fcntl.h ¶
- :unixsupport.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:lseek.c.x Ä  ¶
- :lseek.c ¶
- :unixsupport.h
-
-:macosunix.c.x Ä  ¶
- :macosunix.c ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"time.h ¶
- :unixsupport.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Quickdraw.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"MacErrors.h
-
-:mkdir.c.x Ä  ¶
- :mkdir.c ¶
- :unixsupport.h
-
-:open.c.x Ä  ¶
- :open.c ¶
- :unixsupport.h ¶
- "{CIncludes}"fcntl.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:opendir.c.x Ä  ¶
- :opendir.c ¶
- :unixsupport.h
-
-:pipe.c.x Ä  ¶
- :pipe.c ¶
- :unixsupport.h
-
-:putenv.c.x Ä  ¶
- :putenv.c ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:read.c.x Ä  ¶
- :read.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:readdir.c.x Ä  ¶
- :readdir.c ¶
- :unixsupport.h
-
-:readlink.c.x Ä  ¶
- :readlink.c ¶
- :unixsupport.h
-
-:rename.c.x Ä  ¶
- :rename.c ¶
- "{CIncludes}"stdio.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h
-
-:rewinddir.c.x Ä  ¶
- :rewinddir.c ¶
- :unixsupport.h
-
-:rmdir.c.x Ä  ¶
- :rmdir.c ¶
- :unixsupport.h
-
-:select.c.x Ä  ¶
- :select.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:sendrecv.c.x Ä  ¶
- :sendrecv.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:setsid.c.x Ä  ¶
- :setsid.c ¶
- :unixsupport.h
-
-:shutdown.c.x Ä  ¶
- :shutdown.c ¶
- :unixsupport.h
-
-:signals.c.x Ä  ¶
- :signals.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:sleep.c.x Ä  ¶
- :sleep.c ¶
- :unixsupport.h
-
-:socket.c.x Ä  ¶
- :socket.c ¶
- :unixsupport.h
-
-:socketaddr.c.x Ä  ¶
- :socketaddr.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"errno.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:socketpair.c.x Ä  ¶
- :socketpair.c ¶
- :unixsupport.h
-
-:sockopt.c.x Ä  ¶
- :sockopt.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:stat.c.x Ä  ¶
- :stat.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :cst2constr.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:strofaddr.c.x Ä  ¶
- :strofaddr.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:symlink.c.x Ä  ¶
- :symlink.c ¶
- :unixsupport.h
-
-:termios.c.x Ä  ¶
- :termios.c ¶
- :unixsupport.h ¶
- "{CIncludes}"errno.h
-
-:truncate.c.x Ä  ¶
- :truncate.c ¶
- :unixsupport.h
-
-:unixsupport.c.x Ä  ¶
- :unixsupport.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :cst2constr.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:unlink.c.x Ä  ¶
- :unlink.c ¶
- :unixsupport.h
-
-:utimes.c.x Ä  ¶
- :utimes.c ¶
- :unixsupport.h
-
-:write.c.x Ä  ¶
- :write.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 23:43:16 on 27 fŽv 2001 by MakeDepend
-
-:accept.c.o Ä  ¶
- :accept.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:access.c.o Ä  ¶
- :access.c ¶
- :unixsupport.h
-
-:addrofstr.c.o Ä  ¶
- :addrofstr.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:alarm.c.o Ä  ¶
- :alarm.c ¶
- :unixsupport.h
-
-:bind.c.o Ä  ¶
- :bind.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:chdir.c.o Ä  ¶
- :chdir.c ¶
- :unixsupport.h
-
-:chmod.c.o Ä  ¶
- :chmod.c ¶
- :unixsupport.h
-
-:close.c.o Ä  ¶
- :close.c ¶
- :unixsupport.h
-
-:closedir.c.o Ä  ¶
- :closedir.c ¶
- :unixsupport.h
-
-:connect.c.o Ä  ¶
- :connect.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:cst2constr.c.o Ä  ¶
- :cst2constr.c ¶
- :cst2constr.h
-
-:cstringv.c.o Ä  ¶
- :cstringv.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:dup.c.o Ä  ¶
- :dup.c ¶
- :unixsupport.h
-
-:dup2.c.o Ä  ¶
- :dup2.c ¶
- :unixsupport.h
-
-:errmsg.c.o Ä  ¶
- :errmsg.c ¶
- "{CIncludes}"errno.h
-
-:exit.c.o Ä  ¶
- :exit.c ¶
- :unixsupport.h
-
-:fchmod.c.o Ä  ¶
- :fchmod.c ¶
- :unixsupport.h
-
-:fchown.c.o Ä  ¶
- :fchown.c ¶
- :unixsupport.h
-
-:fcntl.c.o Ä  ¶
- :fcntl.c ¶
- :unixsupport.h ¶
- "{CIncludes}"fcntl.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:ftruncate.c.o Ä  ¶
- :ftruncate.c ¶
- :unixsupport.h
-
-:getcwd.c.o Ä  ¶
- :getcwd.c ¶
- :unixsupport.h
-
-:getgroups.c.o Ä  ¶
- :getgroups.c ¶
- "{CIncludes}"limits.h ¶
- :unixsupport.h
-
-:gethost.c.o Ä  ¶
- :gethost.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:gethostname.c.o Ä  ¶
- :gethostname.c ¶
- :unixsupport.h
-
-:getpeername.c.o Ä  ¶
- :getpeername.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:getproto.c.o Ä  ¶
- :getproto.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:getserv.c.o Ä  ¶
- :getserv.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:getsockname.c.o Ä  ¶
- :getsockname.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:gettimeofday.c.o Ä  ¶
- :gettimeofday.c ¶
- :unixsupport.h
-
-:gmtime.c.o Ä  ¶
- :gmtime.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"time.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:itimer.c.o Ä  ¶
- :itimer.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:listen.c.o Ä  ¶
- :listen.c ¶
- :unixsupport.h
-
-:lockf.c.o Ä  ¶
- :lockf.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"fcntl.h ¶
- :unixsupport.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:lseek.c.o Ä  ¶
- :lseek.c ¶
- :unixsupport.h
-
-:macosunix.c.o Ä  ¶
- :macosunix.c ¶
- "{CIncludes}"Events.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"Resources.h ¶
- "{CIncludes}"TextUtils.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"time.h ¶
- :unixsupport.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Quickdraw.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"MixedMode.h ¶
- "{CIncludes}"NumberFormatting.h ¶
- "{CIncludes}"StringCompare.h ¶
- "{CIncludes}"DateTimeUtils.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"TextCommon.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"IntlResources.h ¶
- "{CIncludes}"Script.h ¶
- "{CIncludes}"MacErrors.h
-
-:mkdir.c.o Ä  ¶
- :mkdir.c ¶
- :unixsupport.h
-
-:open.c.o Ä  ¶
- :open.c ¶
- :unixsupport.h ¶
- "{CIncludes}"fcntl.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"SizeTDef.h
-
-:opendir.c.o Ä  ¶
- :opendir.c ¶
- :unixsupport.h
-
-:pipe.c.o Ä  ¶
- :pipe.c ¶
- :unixsupport.h
-
-:putenv.c.o Ä  ¶
- :putenv.c ¶
- "{CIncludes}"stdlib.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"WCharTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:read.c.o Ä  ¶
- :read.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:readdir.c.o Ä  ¶
- :readdir.c ¶
- :unixsupport.h
-
-:readlink.c.o Ä  ¶
- :readlink.c ¶
- :unixsupport.h
-
-:rename.c.o Ä  ¶
- :rename.c ¶
- "{CIncludes}"stdio.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"SeekDefs.h ¶
- "{CIncludes}"VaListTDef.h
-
-:rewinddir.c.o Ä  ¶
- :rewinddir.c ¶
- :unixsupport.h
-
-:rmdir.c.o Ä  ¶
- :rmdir.c ¶
- :unixsupport.h
-
-:select.c.o Ä  ¶
- :select.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:sendrecv.c.o Ä  ¶
- :sendrecv.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:setsid.c.o Ä  ¶
- :setsid.c ¶
- :unixsupport.h
-
-:shutdown.c.o Ä  ¶
- :shutdown.c ¶
- :unixsupport.h
-
-:signals.c.o Ä  ¶
- :signals.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:sleep.c.o Ä  ¶
- :sleep.c ¶
- :unixsupport.h
-
-:socket.c.o Ä  ¶
- :socket.c ¶
- :unixsupport.h
-
-:socketaddr.c.o Ä  ¶
- :socketaddr.c ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"errno.h ¶
- :unixsupport.h ¶
- :socketaddr.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:socketpair.c.o Ä  ¶
- :socketpair.c ¶
- :unixsupport.h
-
-:sockopt.c.o Ä  ¶
- :sockopt.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:stat.c.o Ä  ¶
- :stat.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :cst2constr.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:strofaddr.c.o Ä  ¶
- :strofaddr.c ¶
- :unixsupport.h ¶
- :socketaddr.h
-
-:symlink.c.o Ä  ¶
- :symlink.c ¶
- :unixsupport.h
-
-:termios.c.o Ä  ¶
- :termios.c ¶
- :unixsupport.h ¶
- "{CIncludes}"errno.h
-
-:truncate.c.o Ä  ¶
- :truncate.c ¶
- :unixsupport.h
-
-:unixsupport.c.o Ä  ¶
- :unixsupport.c ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- :cst2constr.h ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:unlink.c.o Ä  ¶
- :unlink.c ¶
- :unixsupport.h
-
-:utimes.c.o Ä  ¶
- :utimes.c ¶
- :unixsupport.h
-
-:write.c.o Ä  ¶
- :write.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- :unixsupport.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-macosunix_startup.cmoÄ macosunix_startup.cmi 
-macosunix_startup.cmxÄ macosunix_startup.cmi 
-unix.cmoÄ unix.cmi 
-unix.cmxÄ unix.cmi 
diff --git a/otherlibs/macosunix/macosunix.c b/otherlibs/macosunix/macosunix.c
deleted file mode 100644
index f0dc8f72..00000000
--- a/otherlibs/macosunix/macosunix.c
+++ /dev/null
@@ -1,119 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*          Damien Doligez, projet Moscova, 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: macosunix.c,v 1.4 2001/12/07 13:40:13 xleroy Exp $ */
-
-#include <Events.h>
-#include <Processes.h>
-#include <Resources.h>
-#include <TextUtils.h>
-
-#include <errno.h>
-#include <string.h>
-#include <time.h>
-
-#include <alloc.h>
-#include <mlvalues.h>
-#include <ui.h>
-
-#include "unixsupport.h"
-
-
-static unsigned long start_ticks;
-
-value macosunix_startup (value unit)  /* ML */
-{
-  start_ticks = TickCount ();
-
-  return Val_unit;
-}
-
-value unix_getlogin (void)            /* ML */
-{
-  char **hs = (char **) GetString (-16096);
-  if (hs == NULL || *hs == NULL || strlen (*hs) == 0){
-    unix_error (ENOENT, "getlogin", Nothing);
-  }
-  return copy_string (*hs);
-}
-
-value unix_getegid (void) /* ML */
-{
-  return Val_int (1);
-}
-
-value unix_geteuid (void) /* ML */
-{
-  return Val_int (1);
-}
-
-value unix_getgid (void) /* ML */
-{
-  return Val_int (1);
-}
-
-value unix_getuid (void) /* ML */
-{
-  return Val_int (1);
-}
-
-value unix_getpid (void)              /* ML */
-{
-  ProcessSerialNumber psn;
-  
-  GetCurrentProcess (&psn);
-  return Val_long (psn.lowLongOfPSN);
-}
-
-value unix_time (void)                /* ML */
-{
-  return copy_double (time (NULL) /* - 2082844800. */);
-}
-
-value unix_times (void)               /* ML */
-{
-  value res;
-
-  res = alloc_small(4 * Double_wosize, Double_array_tag);
-  Store_double_field(res, 0, (double) (TickCount () - start_ticks) / 60);
-  Store_double_field(res, 1, (double) 0.0);
-  Store_double_field(res, 2, (double) 0.0);
-  Store_double_field(res, 3, (double) 0.0);
-  return res;
-}
-
-#define Unimplemented(f, args) \
-  value unix_##f args { invalid_argument (#f " not implemented"); }
-
-Unimplemented (chown, (value path, value uid, value gid))
-Unimplemented (chroot, (value path))
-Unimplemented (environment, (void))
-Unimplemented (execv, (value path, value args))
-Unimplemented (execve, (value path, value args, value env))
-Unimplemented (execvp, (value path, value args))
-Unimplemented (execvpe, (value path, value args, value env))
-Unimplemented (fork, (value unit))
-Unimplemented (getgrnam, (value name))
-Unimplemented (getgrgid, (value gid))
-Unimplemented (getppid, (void))
-Unimplemented (getpwnam, (value name))
-Unimplemented (getpwuid, (value uid))
-Unimplemented (kill, (value pid, value signal))
-Unimplemented (link, (value path1, value path2))
-Unimplemented (mkfifo, (value path, value mode))
-Unimplemented (nice, (value incr))
-Unimplemented (setgid, (value gid))
-Unimplemented (setuid, (value uid))
-Unimplemented (umask, (value perm))
-Unimplemented (wait, (void))
-Unimplemented (waitpid, (value flags, value pid_req))
diff --git a/otherlibs/macosunix/unix-primitives b/otherlibs/macosunix/unix-primitives
deleted file mode 100644
index 9f920883..00000000
--- a/otherlibs/macosunix/unix-primitives
+++ /dev/null
@@ -1,113 +0,0 @@
-macosunix_startup
-unix_accept
-unix_access
-unix_alarm
-unix_bind
-unix_chdir
-unix_chmod
-unix_chown
-unix_chroot
-unix_clear_close_on_exec
-unix_clear_nonblock
-unix_close
-unix_closedir
-unix_connect
-unix_dup
-unix_dup2
-unix_environment
-unix_error_message
-unix_execv
-unix_execve
-unix_execvp
-unix_execvpe
-unix_exit
-unix_fchmod
-unix_fchown
-unix_fork
-unix_fstat
-unix_ftruncate
-unix_getcwd
-unix_getegid
-unix_geteuid
-unix_getgid
-unix_getgrgid
-unix_getgrnam
-unix_getgroups
-unix_gethostbyaddr
-unix_gethostbyname
-unix_gethostname
-unix_getitimer
-unix_getlogin
-unix_getpeername
-unix_getpid
-unix_getppid
-unix_getprotobyname
-unix_getprotobynumber
-unix_getpwnam
-unix_getpwuid
-unix_getservbyname
-unix_getservbyport
-unix_getsockname
-unix_getsockopt
-unix_gettimeofday
-unix_getuid
-unix_gmtime
-unix_inet_addr_of_string
-unix_kill
-unix_link
-unix_listen
-unix_localtime
-unix_lockf
-unix_lseek
-unix_lstat
-unix_mkdir
-unix_mkfifo
-unix_mktime
-unix_nice
-unix_open
-unix_opendir
-unix_pipe
-unix_putenv
-unix_read
-unix_readdir
-unix_readlink
-unix_recv
-unix_recvfrom
-unix_rename
-unix_rewinddir
-unix_rmdir
-unix_select
-unix_send
-unix_sendto
-unix_set_close_on_exec
-unix_set_nonblock
-unix_setgid
-unix_setitimer
-unix_setsid
-unix_setsockopt
-unix_setuid
-unix_shutdown
-unix_sigpending
-unix_sigprocmask
-unix_sigsuspend
-unix_sleep
-unix_socket
-unix_socketpair
-unix_stat
-unix_string_of_inet_addr
-unix_symlink
-unix_tcdrain
-unix_tcflow
-unix_tcflush
-unix_tcgetattr
-unix_tcsendbreak
-unix_tcsetattr
-unix_time
-unix_times
-unix_truncate
-unix_umask
-unix_unlink
-unix_utimes
-unix_wait
-unix_waitpid
-unix_write
diff --git a/otherlibs/macosunix/unixsupport.h b/otherlibs/macosunix/unixsupport.h
deleted file mode 100644
index 9fe8f1fa..00000000
--- a/otherlibs/macosunix/unixsupport.h
+++ /dev/null
@@ -1,43 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*          Damien Doligez, projet Moscova, 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: unixsupport.h,v 1.2 2001/12/07 13:40:13 xleroy Exp $ */
-
-#define POSIX_SIGNALS
-#define HAS_MEMMOVE
-#define HAS_STRERROR
-#define HAS_SOCKETS
-#define HAS_SOCKLEN_T
-#define HAS_UNISTD
-#define HAS_DIRENT
-#define HAS_REWINDDIR
-#define HAS_GETCWD
-#define HAS_UTIME
-#define HAS_DUP2
-#define HAS_TRUNCATE
-#define HAS_SELECT
-#define HAS_SYMLINK
-#define HAS_GETHOSTNAME
-#define HAS_GETTIMEOFDAY
-#define HAS_MKTIME
-
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-
-#define Nothing ((value) 0)
-
-extern void unix_error (int errcode, char * cmdname, value arg) Noreturn;
-extern void uerror (char * cmdname, value arg) Noreturn;
-
-#define UNIX_BUFFER_SIZE 2048
diff --git a/otherlibs/num/.cvsignore b/otherlibs/num/.cvsignore
new file mode 100644
index 00000000..7786c62f
--- /dev/null
+++ b/otherlibs/num/.cvsignore
@@ -0,0 +1,3 @@
+libnums.x
+*.c.x
+so_locations
diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend
new file mode 100644
index 00000000..406a6bf5
--- /dev/null
+++ b/otherlibs/num/.depend
@@ -0,0 +1,36 @@
+bng.o: bng.c bng.h bng_ppc.c bng_digit.c
+bng_alpha.o: bng_alpha.c
+bng_amd64.o: bng_amd64.c
+bng_digit.o: bng_digit.c
+bng_ia32.o: bng_ia32.c
+bng_mips.o: bng_mips.c
+bng_ppc.o: bng_ppc.c
+bng_sparc.o: bng_sparc.c
+nat_stubs.o: nat_stubs.c ../../byterun/alloc.h \
+  ../../byterun/compatibility.h ../../byterun/misc.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/mlvalues.h ../../byterun/custom.h ../../byterun/intext.h \
+  ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h
+big_int.cmi: nat.cmi 
+num.cmi: big_int.cmi nat.cmi ratio.cmi 
+ratio.cmi: big_int.cmi nat.cmi 
+arith_flags.cmo: arith_flags.cmi 
+arith_flags.cmx: arith_flags.cmi 
+arith_status.cmo: arith_flags.cmi arith_status.cmi 
+arith_status.cmx: arith_flags.cmx arith_status.cmi 
+big_int.cmo: int_misc.cmi nat.cmi big_int.cmi 
+big_int.cmx: int_misc.cmx nat.cmx big_int.cmi 
+int_misc.cmo: int_misc.cmi 
+int_misc.cmx: int_misc.cmi 
+nat.cmo: int_misc.cmi nat.cmi 
+nat.cmx: int_misc.cmx nat.cmi 
+num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi 
+num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi 
+ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \
+    ratio.cmi 
+ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \
+    ratio.cmi 
+string_misc.cmo: string_misc.cmi 
+string_misc.cmx: string_misc.cmi 
diff --git a/otherlibs/num/.depend.nt b/otherlibs/num/.depend.nt
new file mode 100644
index 00000000..0d604eab
--- /dev/null
+++ b/otherlibs/num/.depend.nt
@@ -0,0 +1,56 @@
+nat_stubs.dobj: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \
+ ../../byterun/config.h ../../byterun/../config/m.h \
+ ../../byterun/../config/s.h ../../byterun/mlvalues.h \
+ ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \
+ ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/memory.h \
+ ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+ ../../byterun/minor_gc.h nat.h bignum/h/BigNum.h bignum/h/BntoBnn.h
+big_int.cmi: nat.cmi 
+num.cmi: big_int.cmi nat.cmi ratio.cmi 
+ratio.cmi: big_int.cmi nat.cmi 
+arith_flags.cmo: arith_flags.cmi 
+arith_flags.cmx: arith_flags.cmi 
+arith_status.cmo: arith_flags.cmi arith_status.cmi 
+arith_status.cmx: arith_flags.cmx arith_status.cmi 
+big_int.cmo: int_misc.cmi nat.cmi big_int.cmi 
+big_int.cmx: int_misc.cmx nat.cmx big_int.cmi 
+int_misc.cmo: int_misc.cmi 
+int_misc.cmx: int_misc.cmi 
+nat.cmo: int_misc.cmi nat.cmi 
+nat.cmx: int_misc.cmx nat.cmi 
+num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi 
+num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi 
+ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \
+    ratio.cmi 
+ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \
+    ratio.cmi 
+string_misc.cmo: string_misc.cmi 
+string_misc.cmx: string_misc.cmi 
+nat_stubs.sobj: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \
+ ../../byterun/config.h ../../byterun/../config/m.h \
+ ../../byterun/../config/s.h ../../byterun/mlvalues.h \
+ ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \
+ ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/memory.h \
+ ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+ ../../byterun/minor_gc.h nat.h bignum/h/BigNum.h bignum/h/BntoBnn.h
+big_int.cmi: nat.cmi 
+num.cmi: big_int.cmi nat.cmi ratio.cmi 
+ratio.cmi: big_int.cmi nat.cmi 
+arith_flags.cmo: arith_flags.cmi 
+arith_flags.cmx: arith_flags.cmi 
+arith_status.cmo: arith_flags.cmi arith_status.cmi 
+arith_status.cmx: arith_flags.cmx arith_status.cmi 
+big_int.cmo: int_misc.cmi nat.cmi big_int.cmi 
+big_int.cmx: int_misc.cmx nat.cmx big_int.cmi 
+int_misc.cmo: int_misc.cmi 
+int_misc.cmx: int_misc.cmi 
+nat.cmo: int_misc.cmi nat.cmi 
+nat.cmx: int_misc.cmx nat.cmi 
+num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi 
+num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi 
+ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \
+    ratio.cmi 
+ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \
+    ratio.cmi 
+string_misc.cmo: string_misc.cmi 
+string_misc.cmx: string_misc.cmi 
diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile
new file mode 100644
index 00000000..69ede51b
--- /dev/null
+++ b/otherlibs/num/Makefile
@@ -0,0 +1,86 @@
+#########################################################################
+#                                                                       #
+#                            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.30 2003/10/24 09:17:31 xleroy Exp $
+
+# Makefile for the "num" (exact rational arithmetic) library
+
+include ../../config/Makefile
+
+# Compilation options
+CC=$(BYTECC)
+CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \
+          -DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
+CAMLC=../../ocamlcomp.sh -w s
+CAMLOPT=../../ocamlcompopt.sh -w s
+MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
+COMPFLAGS=-warn-error A
+
+CAMLOBJS=int_misc.cmo string_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
+  ratio.cmo num.cmo arith_status.cmo
+
+CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
+
+COBJS=bng.o nat_stubs.o
+
+all: libnums.a nums.cma $(CMIFILES)
+
+allopt: libnums.a nums.cmxa $(CMIFILES)
+
+nums.cma: $(CAMLOBJS)
+	$(MKLIB) -ocamlc '$(CAMLC)' -o nums $(CAMLOBJS)
+
+nums.cmxa: $(CAMLOBJS:.cmo=.cmx)
+	$(MKLIB) -ocamlopt '$(CAMLOPT)' -o nums $(CAMLOBJS:.cmo=.cmx)
+
+libnums.a: $(COBJS)
+	$(MKLIB) -o nums $(COBJS)
+
+$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt
+
+install:
+	if test -f dllnums.so; then cp dllnums.so $(STUBLIBDIR)/dllnums.so; fi
+	cp libnums.a $(LIBDIR)/libnums.a
+	cd $(LIBDIR); $(RANLIB) libnums.a
+	cp nums.cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(LIBDIR)
+
+installopt:
+	cp $(CAMLOBJS:.cmo=.cmx) nums.cmxa nums.a $(LIBDIR)
+	cd $(LIBDIR); $(RANLIB) nums.a
+
+partialclean:
+	rm -f *.cm*
+
+clean: partialclean
+	rm -f *.a *.o *.so
+	cd test; $(MAKE) clean
+
+.SUFFIXES: .ml .mli .cmi .cmo .cmx
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $<
+
+bng.o: bng.h bng_digit.c \
+       bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c
+
+depend:
+	gcc -MM $(CFLAGS) *.c > .depend
+	../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
+
+include .depend
diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt
new file mode 100644
index 00000000..06938d0a
--- /dev/null
+++ b/otherlibs/num/Makefile.nt
@@ -0,0 +1,97 @@
+#########################################################################
+#                                                                       #
+#                            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.17 2003/10/24 09:17:31 xleroy Exp $
+
+# Makefile for the "num" (exact rational arithmetic) library
+
+include ../../config/Makefile
+
+# Compilation options
+CC=$(BYTECC)
+CFLAGS=-O -I../../byterun \
+          -DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
+CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot -w s
+CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -w s
+
+CAMLOBJS=int_misc.cmo string_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
+  ratio.cmo num.cmo arith_status.cmo
+
+CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
+
+DCOBJS=bng.$(DO) nat_stubs.$(DO)
+SCOBJS=bng.$(SO) nat_stubs.$(SO)
+
+all: dllnums.dll libnums.$(A) nums.cma $(CMIFILES)
+
+allopt: libnums.$(A) nums.cmxa $(CMIFILES)
+
+nums.cma: $(CAMLOBJS)
+	$(CAMLC) -a -o nums.cma $(CAMLOBJS) -dllib -lnums -cclib -lnums
+
+nums.cmxa: $(CAMLOBJS:.cmo=.cmx)
+	$(CAMLOPT) -a -o nums.cmxa $(CAMLOBJS:.cmo=.cmx) -cclib -lnums
+
+dllnums.dll: $(DCOBJS)
+	$(call MKDLL,dllnums.dll,tmp.$(A),\
+	  $(DCOBJS) ../../byterun/ocamlrun.$(A))
+	rm tmp.*
+
+libnums.$(A): $(SCOBJS)
+	$(call MKLIB,libnums.$(A),$(SCOBJS))
+
+$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt
+
+install:
+	cp dllnums.dll $(STUBLIBDIR)/dllnums.dll
+	cp libnums.$(A) $(LIBDIR)/libnums.$(A)
+	cp nums.cma $(CMIFILES) $(LIBDIR)
+
+installopt:
+	cp $(CAMLOBJS:.cmo=.cmx) nums.cmxa nums.$(A) $(LIBDIR)
+
+partialclean:
+	rm -f *.cm*
+
+clean: partialclean
+	rm -f *.dll *.$(A) *.$(O)
+	cd bignum ; $(MAKEREC) scratch
+	cd test ; $(MAKEREC) clean
+
+.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(DO) .$(SO)
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $<
+
+.c.$(DO):
+	$(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $<
+	mv $*.$(O) $*.$(DO)
+
+.c.$(SO):
+	$(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<
+	mv $*.$(O) $*.$(SO)
+
+bng.$(DO) bng.$(SO): bng.h bng_digit.c \
+       bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c
+
+depend:
+	sed -e 's/\.o/.$(DO)/g' .depend > .depend.nt
+	sed -e 's/\.o/.$(SO)/g' .depend >> .depend.nt
+
+include .depend.nt
diff --git a/otherlibs/num/README b/otherlibs/num/README
new file mode 100644
index 00000000..d4969bfd
--- /dev/null
+++ b/otherlibs/num/README
@@ -0,0 +1,55 @@
+The "libnum" library implements exact-precision arithmetic on
+big integers and on rationals.
+
+This library is derived from Valerie Menissie-Morain's implementation
+of rational arithmetic for Caml V3.1 (INRIA).  Xavier Leroy (INRIA)
+did the Caml Light port.  Victor Manuel Gulias Fernandez did the
+initial Caml Special Light port.  Pierre Weis did most of the
+maintenance and bug fixing.
+
+Initially, the low-level big integer operations were provided by the
+BigNum package developed by Bernard Serpette, Jean Vuillemin and
+Jean-Claude Herve (INRIA and Digital PRL).  License issues forced us to 
+replace the BigNum package.  The current implementation of low-level
+big integer operations is due to Xavier Leroy.
+
+This library is documented in "The CAML Numbers Reference Manual" by 
+Valerie Menissier-Morain, technical report 141, INRIA, july 1992,
+available at ftp://ftp.inria.fr/INRIA/publication/RT/RT-0141.ps.gz
+
+
+USAGE:
+
+To use the bignum library from your programs, just do
+
+    ocamlc <options> nums.cma <.cmo and .ml files>
+or
+    ocamlopt <options> nums.cmxa <.cmx and .ml files>
+
+for the linking phase.
+
+If you'd like to have the bignum functions available at toplevel, do
+
+    ocamlmktop -o ocamltopnum <options> nums.cma <.cmo and .ml files>
+    ./ocamltopnum
+
+As an example, try:
+
+        open Num;;
+        let rec fact n =
+          if n = 0 then Int 1 else mult_num (num_of_int n) (fact(n-1));;
+        string_of_num(fact 1000);;
+
+
+PROCESSOR-SPECIFIC OPTIMIZATIONS:
+
+When compiled with GCC, the low-level primitives use "inline extended asm"
+to exploit useful features of the target processor (additions and 
+subtractions with carry; double-width multiplication, division).
+Here are the processors for which such optimizations are available:
+  IA32 (x86)       (carry, dwmult, dwdiv, 64-bit ops with SSE2 if available)
+  AMD64 (Opteron)  (carry, dwmult, dwdiv)
+  PowerPC          (carry, dwmult)
+  Alpha            (dwmult)
+  SPARC            (carry, dwmult, dwdiv)
+  MIPS             (dwmult)
diff --git a/otherlibs/num/arith_flags.ml b/otherlibs/num/arith_flags.ml
new file mode 100644
index 00000000..19103ed9
--- /dev/null
+++ b/otherlibs/num/arith_flags.ml
@@ -0,0 +1,25 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: arith_flags.ml,v 1.4 2001/12/07 13:40:14 xleroy Exp $ *)
+
+let error_when_null_denominator_flag = ref true;;
+
+let normalize_ratio_flag = ref false;;
+
+let normalize_ratio_when_printing_flag = ref true;;
+
+let floating_precision = ref 12;;
+
+let approx_printing_flag = ref false;;
+
diff --git a/otherlibs/num/arith_flags.mli b/otherlibs/num/arith_flags.mli
new file mode 100644
index 00000000..30e5300c
--- /dev/null
+++ b/otherlibs/num/arith_flags.mli
@@ -0,0 +1,20 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: arith_flags.mli,v 1.5 2001/12/07 13:40:14 xleroy Exp $ *)
+
+val error_when_null_denominator_flag : bool ref
+val normalize_ratio_flag : bool ref
+val normalize_ratio_when_printing_flag : bool ref
+val floating_precision : int ref
+val approx_printing_flag : bool ref
diff --git a/otherlibs/num/arith_status.ml b/otherlibs/num/arith_status.ml
new file mode 100644
index 00000000..a15b5816
--- /dev/null
+++ b/otherlibs/num/arith_status.ml
@@ -0,0 +1,100 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: arith_status.ml,v 1.4 2001/12/07 13:40:14 xleroy Exp $ *)
+
+open Arith_flags;;
+
+let get_error_when_null_denominator () =
+  !error_when_null_denominator_flag 
+and set_error_when_null_denominator choice =
+ error_when_null_denominator_flag := choice;;
+
+let get_normalize_ratio () = !normalize_ratio_flag 
+and set_normalize_ratio choice = normalize_ratio_flag := choice;; 
+
+let get_normalize_ratio_when_printing () = 
+  !normalize_ratio_when_printing_flag
+and set_normalize_ratio_when_printing choice = 
+ normalize_ratio_when_printing_flag := choice;; 
+
+let get_floating_precision () = !floating_precision
+and set_floating_precision i = floating_precision := i;;
+
+let get_approx_printing () = !approx_printing_flag
+and set_approx_printing b = approx_printing_flag := b;;
+
+let arith_print_string s = print_string s; print_string " --> ";;
+
+let arith_print_bool = function
+  true -> print_string "ON"
+| _ -> print_string "OFF"
+;;
+
+let arith_status () =
+  print_newline ();
+
+  arith_print_string
+  "Normalization during computation";
+  arith_print_bool (get_normalize_ratio ());
+  print_newline ();
+  print_string "     (returned by get_normalize_ratio ())";
+  print_newline ();
+  print_string "     (modifiable with set_normalize_ratio <your choice>)";
+  print_newline ();
+  print_newline ();
+
+  arith_print_string
+  "Normalization when printing";
+  arith_print_bool (get_normalize_ratio_when_printing ());
+  print_newline ();
+  print_string
+  "     (returned by get_normalize_ratio_when_printing ())";
+  print_newline ();
+  print_string
+  "     (modifiable with set_normalize_ratio_when_printing <your choice>)";
+  print_newline ();
+  print_newline ();
+
+  arith_print_string
+  "Floating point approximation when printing rational numbers";
+  arith_print_bool (get_approx_printing ());
+  print_newline ();
+  print_string
+  "     (returned by get_approx_printing ())";
+  print_newline ();
+  print_string
+  "     (modifiable with set_approx_printing <your choice>)";
+  print_newline ();
+  (if (get_approx_printing ())
+      then (print_string "  Default precision = ";
+            print_int (get_floating_precision ());
+            print_newline ();
+            print_string "     (returned by get_floating_precision ())";
+            print_newline ();
+            print_string
+              "     (modifiable with set_floating_precision <your choice>)";
+            print_newline ();
+            print_newline ())
+      else print_newline());
+
+  arith_print_string
+  "Error when a rational denominator is null";
+  arith_print_bool (get_error_when_null_denominator ());
+  print_newline ();
+  print_string "     (returned by get_error_when_null_denominator ())";
+  print_newline ();
+  print_string
+  "     (modifiable with set_error_when_null_denominator <your choice>)";
+  print_newline ()
+;;
diff --git a/otherlibs/num/arith_status.mli b/otherlibs/num/arith_status.mli
new file mode 100644
index 00000000..76300eb8
--- /dev/null
+++ b/otherlibs/num/arith_status.mli
@@ -0,0 +1,60 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: arith_status.mli,v 1.6 2001/12/07 13:40:14 xleroy Exp $ *)
+
+(** Flags that control rational arithmetic. *)
+
+val arith_status: unit -> unit
+        (** Print the current status of the arithmetic flags. *)
+
+val get_error_when_null_denominator : unit -> bool
+        (** See {!Arith_status.set_error_when_null_denominator}.*)
+val set_error_when_null_denominator : bool -> unit
+        (** Get or set the flag [null_denominator]. When on, attempting to 
+           create a rational with a null denominator raises an exception.
+           When off, rationals with null denominators are accepted.
+           Initially: on. *)
+
+val get_normalize_ratio : unit -> bool
+        (** See {!Arith_status.set_normalize_ratio}.*)
+val set_normalize_ratio : bool -> unit
+        (** Get or set the flag [normalize_ratio]. When on, rational
+           numbers are normalized after each operation. When off,
+           rational numbers are not normalized until printed.
+           Initially: off. *)
+
+val get_normalize_ratio_when_printing : unit -> bool
+        (** See {!Arith_status.set_normalize_ratio_when_printing}.*)
+val set_normalize_ratio_when_printing : bool -> unit
+        (** Get or set the flag [normalize_ratio_when_printing].
+           When on, rational numbers are normalized before being printed.
+           When off, rational numbers are printed as is, without normalization.
+           Initially: on. *)
+
+val get_approx_printing : unit -> bool
+        (** See {!Arith_status.set_approx_printing}.*)
+val set_approx_printing : bool -> unit
+        (** Get or set the flag [approx_printing].
+           When on, rational numbers are printed as a decimal approximation.
+           When off, rational numbers are printed as a fraction.
+           Initially: off. *)
+
+val get_floating_precision : unit -> int
+        (** See {!Arith_status.set_floating_precision}.*)
+val set_floating_precision : int -> unit
+        (** Get or set the parameter [floating_precision].
+           This parameter is the number of digits displayed when
+           [approx_printing] is on.
+           Initially: 12. *)
+
diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml
new file mode 100644
index 00000000..af666090
--- /dev/null
+++ b/otherlibs/num/big_int.ml
@@ -0,0 +1,604 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: big_int.ml,v 1.18 2003/12/29 19:26:15 doligez Exp $ *)
+
+open Int_misc
+open Nat
+
+type big_int = 
+   { sign : int; 
+     abs_value : nat }
+
+let create_big_int sign nat =  
+ if sign = 1 || sign = -1 ||
+    (sign = 0 &&
+     is_zero_nat nat 0 (num_digits_nat nat 0 (length_nat nat)))
+ then { sign = sign; 
+         abs_value = nat }
+ else invalid_arg "create_big_int"
+
+(* Sign of a big_int *)
+let sign_big_int bi = bi.sign
+
+let zero_big_int =
+ { sign = 0;
+   abs_value = make_nat 1 }
+
+let unit_big_int =  
+  { sign = 1;
+    abs_value = nat_of_int 1 }
+
+(* Number of digits in a big_int *)
+let num_digits_big_int bi = 
+ num_digits_nat (bi.abs_value) 0 (length_nat bi.abs_value) 
+
+(* Opposite of a big_int *)
+let minus_big_int bi = 
+ { sign = - bi.sign;
+   abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)}
+
+(* Absolute value of a big_int *)
+let abs_big_int bi = 
+    { sign = if bi.sign = 0 then 0 else 1;
+      abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)}
+
+(* Comparison operators on big_int *)
+
+(* 
+   compare_big_int (bi, bi2) = sign of (bi-bi2) 
+   i.e. 1 if bi > bi2
+        0 if bi = bi2
+        -1 if bi < bi2
+*)
+let compare_big_int bi1 bi2 =
+  if bi1.sign = 0 && bi2.sign = 0 then 0
+  else if bi1.sign < bi2.sign then -1
+  else if bi1.sign > bi2.sign then 1
+  else if bi1.sign = 1 then
+            compare_nat (bi1.abs_value) 0 (num_digits_big_int bi1) 
+                        (bi2.abs_value) 0 (num_digits_big_int bi2)
+  else
+            compare_nat (bi2.abs_value) 0 (num_digits_big_int bi2) 
+                        (bi1.abs_value) 0 (num_digits_big_int bi1)
+
+let eq_big_int bi1 bi2 = compare_big_int bi1 bi2 = 0
+and le_big_int bi1 bi2 = compare_big_int bi1 bi2 <= 0
+and ge_big_int bi1 bi2 = compare_big_int bi1 bi2 >= 0
+and lt_big_int bi1 bi2 = compare_big_int bi1 bi2 < 0
+and gt_big_int bi1 bi2 = compare_big_int bi1 bi2 > 0
+
+let max_big_int bi1 bi2 = if lt_big_int bi1 bi2 then bi2 else bi1
+and min_big_int bi1 bi2 = if gt_big_int bi1 bi2 then bi2 else bi1
+
+(* Operations on big_int *)
+
+let pred_big_int bi = 
+ match bi.sign with
+    0 -> { sign = -1; abs_value = nat_of_int 1}
+  | 1 -> let size_bi = num_digits_big_int bi in
+          let copy_bi = copy_nat (bi.abs_value) 0 size_bi in
+            decr_nat copy_bi 0 size_bi 0;
+            { sign = if is_zero_nat copy_bi 0 size_bi then 0 else 1;
+              abs_value = copy_bi }
+  | _ -> let size_bi = num_digits_big_int bi in
+         let size_res = succ (size_bi) in
+         let copy_bi = create_nat (size_res) in
+          blit_nat copy_bi 0 (bi.abs_value) 0 size_bi;
+          set_digit_nat copy_bi size_bi 0;
+          incr_nat copy_bi 0 size_res 1; 
+          { sign = -1;
+            abs_value = copy_bi }
+
+let succ_big_int bi =
+ match bi.sign with
+    0 -> {sign = 1; abs_value = nat_of_int 1}
+  | -1 -> let size_bi = num_digits_big_int bi in
+           let copy_bi = copy_nat (bi.abs_value) 0 size_bi in
+            decr_nat copy_bi 0 size_bi 0;
+            { sign = if is_zero_nat copy_bi 0 size_bi then 0 else -1;
+              abs_value = copy_bi }
+  | _ -> let size_bi = num_digits_big_int bi in
+         let size_res = succ (size_bi) in
+         let copy_bi = create_nat (size_res) in
+          blit_nat copy_bi 0 (bi.abs_value) 0 size_bi;
+          set_digit_nat copy_bi size_bi 0;
+          incr_nat copy_bi 0 size_res 1;
+          { sign = 1;
+            abs_value = copy_bi }
+
+let add_big_int bi1 bi2 = 
+ let size_bi1 = num_digits_big_int bi1
+ and size_bi2 = num_digits_big_int bi2 in
+  if bi1.sign = bi2.sign
+   then    (* Add absolute values if signs are the same *)
+    { sign = bi1.sign;
+      abs_value = 
+       match compare_nat (bi1.abs_value) 0 size_bi1 
+                         (bi2.abs_value) 0 size_bi2 with
+        -1 -> let res = create_nat (succ size_bi2) in
+                (blit_nat res 0 (bi2.abs_value) 0 size_bi2; 
+                 set_digit_nat res size_bi2 0;
+                 add_nat res 0 (succ size_bi2) 
+                          (bi1.abs_value) 0 size_bi1 0;
+                 res)
+       |_  -> let res = create_nat (succ size_bi1) in
+               (blit_nat res 0 (bi1.abs_value) 0 size_bi1;
+                set_digit_nat res size_bi1 0;
+                add_nat res 0 (succ size_bi1) 
+                         (bi2.abs_value) 0 size_bi2 0;
+                res)}
+
+  else      (* Subtract absolute values if signs are different *)
+    match compare_nat (bi1.abs_value) 0 size_bi1 
+                      (bi2.abs_value) 0 size_bi2 with
+       0 -> zero_big_int
+     | 1 -> { sign = bi1.sign;
+               abs_value = 
+                let res = copy_nat (bi1.abs_value) 0 size_bi1 in
+                 (sub_nat res 0 size_bi1 
+                           (bi2.abs_value) 0 size_bi2 1;
+                  res) }
+     | _ -> { sign = bi2.sign;
+              abs_value = 
+               let res = copy_nat (bi2.abs_value) 0 size_bi2 in
+                 (sub_nat res 0 size_bi2 
+                           (bi1.abs_value) 0 size_bi1 1;
+                  res) }
+
+(* Coercion with int type *)
+let big_int_of_int i =
+  { sign = sign_int i;
+    abs_value =
+      let res = (create_nat 1)
+      in (if i = monster_int
+             then (set_digit_nat res 0 biggest_int;
+                   incr_nat res 0 1 1; ())
+             else set_digit_nat res 0 (abs i));
+      res }
+
+let add_int_big_int i bi = add_big_int (big_int_of_int i) bi
+
+let sub_big_int bi1 bi2 = add_big_int bi1 (minus_big_int bi2)
+
+(* Returns i * bi *)
+let mult_int_big_int i bi =
+ let size_bi = num_digits_big_int bi in
+ let size_res = succ size_bi in
+  if i = monster_int
+     then let res = create_nat size_res in
+            blit_nat res 0 (bi.abs_value) 0 size_bi;
+            set_digit_nat res size_bi 0;
+            mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi 
+                           (nat_of_int biggest_int) 0;
+            { sign = - (sign_big_int bi);
+              abs_value = res }             
+     else let res = make_nat (size_res) in
+          mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi 
+                         (nat_of_int (abs i)) 0;
+          { sign = (sign_int i) * (sign_big_int bi);
+            abs_value = res } 
+
+let mult_big_int bi1 bi2 =
+ let size_bi1 = num_digits_big_int bi1
+ and size_bi2 = num_digits_big_int bi2 in
+ let size_res = size_bi1 + size_bi2 in
+ let res = make_nat (size_res) in
+  { sign = bi1.sign * bi2.sign;
+    abs_value = 
+         if size_bi2 > size_bi1
+           then (mult_nat res 0 size_res (bi2.abs_value) 0 size_bi2 
+                          (bi1.abs_value) 0 size_bi1;res)
+           else (mult_nat res 0 size_res (bi1.abs_value) 0 size_bi1 
+                          (bi2.abs_value) 0 size_bi2;res) }
+
+(* (quotient, rest) of the euclidian division of 2 big_int *)
+let quomod_big_int bi1 bi2 =
+ if bi2.sign = 0 then raise Division_by_zero
+ else
+  let size_bi1 = num_digits_big_int bi1
+  and size_bi2 = num_digits_big_int bi2 in
+   match compare_nat (bi1.abs_value) 0 size_bi1 
+                     (bi2.abs_value) 0 size_bi2 with
+      -1 -> (* 1/2 -> 0, reste 1, -1/2 -> -1, reste 1 *)
+             if bi1.sign = -1
+              then (big_int_of_int(-1), add_big_int bi2 bi1)
+              else (big_int_of_int 0, bi1)
+    | 0 -> (big_int_of_int (bi1.sign * bi2.sign), zero_big_int)
+    | _ -> let bi1_negatif = bi1.sign = -1 in 
+           let size_q =
+            if bi1_negatif 
+             then succ (max (succ (size_bi1 - size_bi2)) 1)
+             else max (succ (size_bi1 - size_bi2)) 1
+           and size_r = succ (max size_bi1 size_bi2) 
+            (* r is long enough to contain both quotient and remainder *)
+            (* of the euclidian division *)
+           in
+            (* set up quotient, remainder *)
+            let q = create_nat size_q
+            and r = create_nat size_r in
+            blit_nat r 0 (bi1.abs_value) 0 size_bi1;
+            set_to_zero_nat r size_bi1 (size_r - size_bi1);
+
+            (* do the division of |bi1| by |bi2|
+               - at the beginning, r contains |bi1| 
+               - at the end, r contains 
+                 * in the size_bi2 least significant digits, the remainder 
+                 * in the size_r-size_bi2 most significant digits, the quotient
+              note the conditions for application of div_nat are verified here 
+             *)
+            div_nat r 0 size_r (bi2.abs_value) 0 size_bi2;
+
+            (* separate quotient and remainder *)
+            blit_nat q 0 r size_bi2 (size_r - size_bi2);
+            let not_null_mod = not (is_zero_nat r 0 size_bi2) in
+
+            (* correct the signs, adjusting the quotient and remainder *)
+            if bi1_negatif && not_null_mod
+             then 
+              (* bi1<0, r>0, noting r for (r, size_bi2) the remainder,      *)
+              (* we have |bi1|=q * |bi2| + r with 0 < r < |bi2|,            *)
+              (* thus -bi1 = q * |bi2| + r                                  *)
+              (* and bi1 = (-q) * |bi2| + (-r) with -|bi2| < (-r) < 0       *)
+              (* thus bi1 = -(q+1) * |bi2| + (|bi2|-r)                      *)
+              (* with 0 < (|bi2|-r) < |bi2|                                 *)
+              (* so the quotient has for sign the opposite of the bi2'one   *)
+              (*                 and for value q+1                          *)
+              (* and the remainder is strictly positive                     *)
+              (*                  has for value |bi2|-r                     *)
+              (let new_r = copy_nat (bi2.abs_value) 0 size_bi2 in
+                      (* new_r contains (r, size_bi2) the remainder *)
+                { sign = - bi2.sign;
+                  abs_value = (set_digit_nat q (pred size_q) 0;
+                               incr_nat q 0 size_q 1; q) }, 
+                { sign = 1;
+                 abs_value = 
+                      (sub_nat new_r 0 size_bi2 r 0 size_bi2 1; 
+                      new_r) })
+             else 
+              (if bi1_negatif then set_digit_nat q (pred size_q) 0; 
+                { sign = if is_zero_nat q 0 size_q 
+                          then 0 
+                          else bi1.sign * bi2.sign;
+                  abs_value = q },
+                { sign = if not_null_mod then 1 else 0;
+                  abs_value = copy_nat r 0 size_bi2 })
+
+let div_big_int bi1 bi2 = fst (quomod_big_int bi1 bi2)
+and mod_big_int bi1 bi2 = snd (quomod_big_int bi1 bi2)
+
+let gcd_big_int bi1 bi2 =
+ let size_bi1 = num_digits_big_int bi1 
+ and size_bi2 = num_digits_big_int bi2 in
+  if is_zero_nat (bi1.abs_value) 0 size_bi1 then abs_big_int bi2
+  else if is_zero_nat (bi2.abs_value) 0 size_bi2 then
+        { sign = 1;
+          abs_value = bi1.abs_value }
+  else
+        { sign = 1;
+          abs_value = 
+           match compare_nat (bi1.abs_value) 0 size_bi1 
+                             (bi2.abs_value) 0 size_bi2 with
+           0 -> bi1.abs_value
+         | 1 ->
+            let res = copy_nat (bi1.abs_value) 0 size_bi1 in
+            let len = 
+              gcd_nat res 0 size_bi1 (bi2.abs_value) 0 size_bi2 in
+            copy_nat res 0 len
+         | _ ->
+            let res = copy_nat (bi2.abs_value) 0 size_bi2 in
+            let len = 
+              gcd_nat res 0 size_bi2 (bi1.abs_value) 0 size_bi1 in
+            copy_nat res 0 len
+         }
+
+(* Coercion operators *)
+
+let monster_big_int = big_int_of_int monster_int;;
+
+let monster_nat = monster_big_int.abs_value;;
+
+let is_int_big_int bi =
+  num_digits_big_int bi == 1 &&
+  match compare_nat bi.abs_value 0 1 monster_nat 0 1 with
+  | 0 -> bi.sign == -1
+  | -1 -> true
+  | _ -> false;;
+
+let int_of_big_int bi =
+  try let n = int_of_nat bi.abs_value in
+      if bi.sign = -1 then - n else n
+  with Failure _ ->
+    if eq_big_int bi monster_big_int then monster_int
+    else failwith "int_of_big_int";;
+
+(* Coercion with nat type *)
+let nat_of_big_int bi = 
+ if bi.sign = -1
+ then failwith "nat_of_big_int"
+ else copy_nat (bi.abs_value) 0 (num_digits_big_int bi)
+
+let sys_big_int_of_nat nat off len =
+ let length = num_digits_nat nat off len in 
+    { sign = if is_zero_nat nat off  length then 0 else 1;
+      abs_value = copy_nat nat off length }
+
+let big_int_of_nat nat =
+ sys_big_int_of_nat nat 0 (length_nat nat)
+
+(* Coercion with string type *)
+
+let string_of_big_int bi =
+  if bi.sign = -1
+  then "-" ^ string_of_nat bi.abs_value
+  else string_of_nat bi.abs_value
+
+
+let sys_big_int_of_string_aux s ofs len sgn =
+  if len < 1 then failwith "sys_big_int_of_string";
+  let n = sys_nat_of_string 10 s ofs len in
+  if is_zero_nat n 0 (length_nat n) then zero_big_int
+  else {sign = sgn; abs_value = n}
+;;
+
+let sys_big_int_of_string s ofs len =
+  match s.[ofs] with
+  | '-' -> sys_big_int_of_string_aux s (ofs+1) (len-1) (-1)
+  | '+' -> sys_big_int_of_string_aux s (ofs+1) (len-1) 1
+  | _ -> sys_big_int_of_string_aux s ofs len 1
+;;
+
+let big_int_of_string s =
+  sys_big_int_of_string s 0 (String.length s)
+
+let power_base_nat base nat off len =
+  if is_zero_nat nat off len then nat_of_int 1 else
+  let power_base = make_nat (succ length_of_digit) in
+  let (pmax, pint) = make_power_base base power_base in
+  let (n, rem) = 
+      let (x, y) = quomod_big_int (sys_big_int_of_nat nat off len) 
+                                  (big_int_of_int (succ pmax)) in
+        (int_of_big_int x, int_of_big_int y) in       
+  if n = 0 then copy_nat power_base (pred rem) 1 else
+   begin
+    let res = make_nat n
+    and res2 = make_nat (succ n)
+    and l = num_bits_int n - 2 in
+    let p = ref (1 lsl l) in
+      blit_nat res 0 power_base pmax 1;
+      for i = l downto 0 do
+        let len = num_digits_nat res 0 n in
+        let len2 = min n (2 * len) in
+        let succ_len2 = succ len2 in
+          square_nat res2 0 len2 res 0 len;
+          begin
+           if n land !p > 0
+              then (set_to_zero_nat res 0 len;
+                    mult_digit_nat res 0 succ_len2 
+                                   res2 0 len2 
+                                   power_base pmax; ())
+              else blit_nat res 0 res2 0 len2
+          end;
+          set_to_zero_nat res2 0 len2;
+          p := !p lsr 1
+      done;
+    if rem > 0
+     then (mult_digit_nat res2 0 (succ n)
+                          res 0 n power_base (pred rem);
+           res2)
+     else res
+  end
+
+let power_int_positive_int i n = 
+  match sign_int n with
+    0 -> unit_big_int
+  | -1 -> invalid_arg "power_int_positive_int"
+  | _ -> let nat = power_base_int (abs i) n in
+           { sign = if i >= 0
+                       then sign_int i 
+                       else if n land 1 = 0
+                               then 1 
+                               else -1;
+             abs_value = nat} 
+
+let power_big_int_positive_int bi n = 
+  match sign_int n with
+    0 -> unit_big_int
+  | -1 -> invalid_arg "power_big_int_positive_int"
+  | _ -> let bi_len = num_digits_big_int bi in
+         let res_len = bi_len * n in
+         let res = make_nat res_len 
+         and res2 = make_nat res_len 
+         and l = num_bits_int n - 2 in
+         let p = ref (1 lsl l) in
+           blit_nat res 0 (bi.abs_value) 0 bi_len;
+           for i = l downto 0 do
+             let len = num_digits_nat res 0 res_len in
+             let len2 = min res_len (2 * len) in
+             let succ_len2 = succ len2 in
+               square_nat res2 0 len2 res 0 len;
+               (if n land !p > 0 
+                   then (set_to_zero_nat res 0 len;
+                         mult_nat res 0 succ_len2 
+                                   res2 0 len2 (bi.abs_value) 0 bi_len;
+                         set_to_zero_nat res2 0 len2)
+                   else blit_nat res 0 res2 0 len2;
+                   set_to_zero_nat res2 0 len2);
+               p := !p lsr 1
+           done;
+           {sign = if bi.sign >=  0
+                      then bi.sign 
+                      else if n land 1 = 0
+                              then 1 
+                              else -1;
+            abs_value = res} 
+
+let power_int_positive_big_int i bi = 
+  match sign_big_int bi with
+    0 -> unit_big_int
+  | -1 -> invalid_arg "power_int_positive_big_int"
+  | _ -> let nat = power_base_nat 
+                     (abs i) (bi.abs_value) 0 (num_digits_big_int bi) in
+           { sign = if i >= 0
+                       then sign_int i 
+                       else if is_digit_odd (bi.abs_value) 0
+                               then -1 
+                               else 1;
+             abs_value = nat } 
+
+let power_big_int_positive_big_int bi1 bi2 = 
+  match sign_big_int bi2 with
+    0 -> unit_big_int
+  | -1 -> invalid_arg "power_big_int_positive_big_int"
+  | _ -> let nat = bi2.abs_value
+         and off = 0 
+         and len_bi2 = num_digits_big_int bi2 in
+         let bi1_len = num_digits_big_int bi1 in
+         let res_len = int_of_big_int (mult_int_big_int bi1_len bi2) in
+         let res = make_nat res_len 
+         and res2 = make_nat res_len 
+         and l = (len_bi2 * length_of_digit 
+                  - num_leading_zero_bits_in_digit nat (pred len_bi2)) - 2 in
+         let p = ref (1 lsl l) in
+           blit_nat res 0 (bi1.abs_value) 0 bi1_len;
+           for i = l downto 0 do
+             let nat = copy_nat bi2.abs_value 0 len_bi2 in
+             let len = num_digits_nat res 0 res_len in
+             let len2 = min res_len (2 * len) in
+             let succ_len2 = succ len2 in
+               square_nat res2 0 len2 res 0 len;
+               land_digit_nat nat 0 (nat_of_int !p) 0;
+               if is_zero_nat nat 0 len_bi2 
+                  then (blit_nat res 0 res2 0 len2;
+                        set_to_zero_nat res2 0 len2)
+                  else (set_to_zero_nat res 0 len;
+                        mult_nat res 0 succ_len2 
+                                 res2 0 len2 (bi1.abs_value) 0 bi1_len;
+                        set_to_zero_nat res2 0 len2);
+               p := !p lsr 1
+           done;
+           {sign = if bi1.sign >= 0
+                      then bi1.sign 
+                      else if is_digit_odd (bi2.abs_value) 0
+                              then -1 
+                              else 1;
+            abs_value = res} 
+
+(* base_power_big_int compute bi*base^n *)
+let base_power_big_int base n bi =
+  match sign_int n with
+    0 -> bi
+  | -1 -> let nat = power_base_int base (-n) in
+           let len_nat = num_digits_nat nat 0 (length_nat nat) 
+           and len_bi = num_digits_big_int bi in
+             if len_bi < len_nat then
+               invalid_arg "base_power_big_int"
+             else if len_bi = len_nat &&
+                     compare_digits_nat (bi.abs_value) len_bi nat len_nat = -1
+               then invalid_arg "base_power_big_int"
+             else
+               let copy = create_nat (succ len_bi) in
+                      blit_nat copy 0 (bi.abs_value) 0 len_bi;
+                      set_digit_nat copy len_bi 0;
+                      div_nat copy 0 (succ len_bi) 
+                              nat 0 len_nat;
+                      if not (is_zero_nat copy 0 len_nat) 
+                         then invalid_arg "base_power_big_int"
+                         else { sign = bi.sign;
+                                abs_value = copy_nat copy len_nat 1 }
+  | _ -> let nat = power_base_int base n in
+         let len_nat = num_digits_nat nat 0 (length_nat nat) 
+         and len_bi = num_digits_big_int bi in
+         let new_len = len_bi + len_nat in
+         let res = make_nat new_len in
+           (if len_bi > len_nat
+               then mult_nat res 0 new_len 
+                              (bi.abs_value) 0 len_bi 
+                              nat 0 len_nat
+               else mult_nat res 0 new_len 
+                              nat 0 len_nat 
+                              (bi.abs_value) 0 len_bi)
+          ; if is_zero_nat res 0 new_len
+               then zero_big_int
+               else create_big_int (bi.sign) res
+
+(* Coercion with float type *)
+
+let float_of_big_int bi = 
+  float_of_string (string_of_big_int bi)
+
+(* XL: suppression de big_int_of_float et nat_of_float. *)
+
+(* Other functions needed *)
+
+(* Integer part of the square root of a big_int *)
+let sqrt_big_int bi =
+ match bi.sign with 
+ | 0 -> zero_big_int
+ | -1 -> invalid_arg "sqrt_big_int"
+ | _ -> {sign = 1;
+         abs_value = sqrt_nat (bi.abs_value) 0 (num_digits_big_int bi)}
+
+let square_big_int bi =
+  if bi.sign == 0 then zero_big_int else
+  let len_bi = num_digits_big_int bi in
+  let len_res = 2 * len_bi in
+  let res = make_nat len_res in
+  square_nat res 0 len_res (bi.abs_value) 0 len_bi;
+  {sign = 1; abs_value = res}
+
+(* round off of the futur last digit (of the integer represented by the string
+   argument of the function) that is now the previous one.
+   if s contains an integer of the form (10^n)-1 
+    then s <- only 0 digits and the result_int is true
+   else s <- the round number and the result_int is false *)
+let round_futur_last_digit s off_set length =
+ let l = pred (length + off_set) in 
+  if Char.code(String.get s l) >= Char.code '5'
+    then
+     let rec round_rec l = 
+      let current_char = String.get s l in 
+       if current_char = '9'
+        then
+         (String.set s l '0';
+          if l = off_set then true else round_rec (pred l))
+        else 
+         (String.set s l (Char.chr (succ (Char.code current_char)));
+          false)
+     in round_rec (pred l)
+   else false
+ 
+
+(* Approximation with floating decimal point a` la approx_ratio_exp *)
+let approx_big_int prec bi =
+  let len_bi = num_digits_big_int bi in
+  let n = 
+    max 0
+        (int_of_big_int (
+          add_int_big_int 
+            (-prec) 
+            (div_big_int (mult_big_int (big_int_of_int (pred len_bi)) 
+                                      (big_int_of_string "963295986")) 
+                        (big_int_of_string "100000000")))) in
+  let s =
+    string_of_big_int (div_big_int bi (power_int_positive_int 10 n)) in
+  let (sign, off, len) = 
+    if String.get s 0 = '-'
+       then ("-", 1, succ prec)
+       else ("", 0, prec) in
+  if (round_futur_last_digit s off (succ prec))
+       then (sign^"1."^(String.make prec '0')^"e"^
+             (string_of_int (n + 1 - off + String.length s)))
+       else (sign^(String.sub s off 1)^"."^
+             (String.sub s (succ off) (pred prec))
+             ^"e"^(string_of_int (n - succ off + String.length s)))
diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli
new file mode 100644
index 00000000..7fd13692
--- /dev/null
+++ b/otherlibs/num/big_int.mli
@@ -0,0 +1,143 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: big_int.mli,v 1.10 2002/03/14 20:12:54 xleroy Exp $ *)
+
+(** Operations on arbitrary-precision integers.
+
+   Big integers (type [big_int]) are signed integers of arbitrary size. 
+*)
+  
+open Nat
+ 
+type big_int
+        (** The type of big integers. *)
+
+val zero_big_int : big_int
+        (** The big integer [0]. *)
+val unit_big_int : big_int
+        (** The big integer [1]. *)
+
+(** {6 Arithmetic operations} *)
+
+val minus_big_int : big_int -> big_int
+        (** Unary negation. *)
+val abs_big_int : big_int -> big_int
+        (** Absolute value. *)
+val add_big_int : big_int -> big_int -> big_int
+        (** Addition. *)
+val succ_big_int : big_int -> big_int
+        (** Successor (add 1). *)
+val add_int_big_int : int -> big_int -> big_int
+        (** Addition of a small integer to a big integer. *)
+val sub_big_int : big_int -> big_int -> big_int
+        (** Subtraction. *)
+val pred_big_int : big_int -> big_int
+        (** Predecessor (subtract 1). *)
+val mult_big_int : big_int -> big_int -> big_int
+        (** Multiplication of two big integers. *)
+val mult_int_big_int : int -> big_int -> big_int
+        (** Multiplication of a big integer by a small integer *)
+val square_big_int: big_int -> big_int
+        (** Return the square of the given big integer *)
+val sqrt_big_int: big_int -> big_int
+        (** [sqrt_big_int a] returns the integer square root of [a],
+           that is, the largest big integer [r] such that [r * r <= a].
+           Raise [Invalid_argument] if [a] is negative. *)
+val quomod_big_int : big_int -> big_int -> big_int * big_int
+        (** Euclidean division of two big integers.
+           The first part of the result is the quotient,
+           the second part is the remainder.
+           Writing [(q,r) = quomod_big_int a b], we have
+           [a = q * b + r] and [0 <= r < |b|].
+           Raise [Division_by_zero] if the divisor is zero. *)
+val div_big_int : big_int -> big_int -> big_int
+        (** Euclidean quotient of two big integers.
+           This is the first result [q] of [quomod_big_int] (see above). *)
+val mod_big_int : big_int -> big_int -> big_int
+        (** Euclidean modulus of two big integers.
+           This is the second result [r] of [quomod_big_int] (see above). *)
+val gcd_big_int : big_int -> big_int -> big_int
+        (** Greatest common divisor of two big integers. *)
+val power_int_positive_int: int -> int -> big_int
+val power_big_int_positive_int: big_int -> int -> big_int
+val power_int_positive_big_int: int -> big_int -> big_int
+val power_big_int_positive_big_int: big_int -> big_int -> big_int
+        (** Exponentiation functions.  Return the big integer
+           representing the first argument [a] raised to the power [b]
+           (the second argument).  Depending
+           on the function, [a] and [b] can be either small integers
+           or big integers.  Raise [Invalid_argument] if [b] is negative. *)
+
+(** {6 Comparisons and tests} *)
+
+val sign_big_int : big_int -> int
+        (** Return [0] if the given big integer is zero,
+           [1] if it is positive, and [-1] if it is negative. *)
+val compare_big_int : big_int -> big_int -> int
+        (** [compare_big_int a b] returns [0] if [a] and [b] are equal,
+           [1] if [a] is greater than [b], and [-1] if [a] is smaller
+           than [b]. *)
+val eq_big_int : big_int -> big_int -> bool
+val le_big_int : big_int -> big_int -> bool
+val ge_big_int : big_int -> big_int -> bool
+val lt_big_int : big_int -> big_int -> bool
+val gt_big_int : big_int -> big_int -> bool
+        (** Usual boolean comparisons between two big integers. *)
+val max_big_int : big_int -> big_int -> big_int
+        (** Return the greater of its two arguments. *)
+val min_big_int : big_int -> big_int -> big_int
+        (** Return the smaller of its two arguments. *)
+val num_digits_big_int : big_int -> int
+        (** Return the number of machine words used to store the
+           given big integer.  *)
+
+(** {6 Conversions to and from strings} *)
+
+val string_of_big_int : big_int -> string
+        (** Return the string representation of the given big integer,
+           in decimal (base 10). *)
+val big_int_of_string : string -> big_int
+        (** Convert a string to a big integer, in decimal.
+           The string consists of an optional [-] or [+] sign,
+           followed by one or several decimal digits. *)
+
+(** {6 Conversions to and from other numerical types} *)
+
+val big_int_of_int : int -> big_int
+        (** Convert a small integer to a big integer. *)
+val is_int_big_int : big_int -> bool
+        (** Test whether the given big integer is small enough to
+           be representable as a small integer (type [int])
+           without loss of precision.  On a 32-bit platform,
+           [is_int_big_int a] returns [true] if and only if
+           [a] is between 2{^30} and 2{^30}-1.  On a 64-bit platform,
+           [is_int_big_int a] returns [true] if and only if
+           [a] is between -2{^62} and 2{^62}-1. *)
+val int_of_big_int : big_int -> int
+        (** Convert a big integer to a small integer (type [int]).
+           Raises [Failure "int_of_big_int"] if the big integer
+           is not representable as a small integer. *)
+val float_of_big_int : big_int -> float
+        (** Returns a floating-point number approximating the
+           given big integer. *)
+
+(**/**)
+
+(** {6 For internal use} *)
+val nat_of_big_int : big_int -> nat
+val big_int_of_nat : nat -> big_int
+val base_power_big_int: int -> int -> big_int -> big_int
+val sys_big_int_of_string: string -> int -> int -> big_int
+val round_futur_last_digit : string -> int -> int -> bool
+val approx_big_int: int -> big_int -> string
diff --git a/otherlibs/num/bignum/.cvsignore b/otherlibs/num/bignum/.cvsignore
new file mode 100644
index 00000000..c76baffd
--- /dev/null
+++ b/otherlibs/num/bignum/.cvsignore
@@ -0,0 +1 @@
+libbignum.x
diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c
new file mode 100644
index 00000000..2e6c274b
--- /dev/null
+++ b/otherlibs/num/bng.c
@@ -0,0 +1,434 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: bng.c,v 1.2 2003/11/07 07:59:09 xleroy Exp $ */
+
+#include "bng.h"
+
+#if defined(__GNUC__) && BNG_ASM_LEVEL > 0
+#if defined(BNG_ARCH_ia32)
+#include "bng_ia32.c"
+#elif defined(BNG_ARCH_amd64)
+#include "bng_amd64.c"
+#elif defined(BNG_ARCH_ppc)
+#include "bng_ppc.c"
+#elif defined (BNG_ARCH_alpha)
+#include "bng_alpha.c"
+#elif defined (BNG_ARCH_sparc)
+#include "bng_sparc.c"
+#elif defined (BNG_ARCH_mips)
+#include "bng_mips.c"
+#endif
+#endif
+
+#include "bng_digit.c"
+
+/**** Operations that cannot be overriden ****/
+
+/* Return number of leading zero bits in d */
+int bng_leading_zero_bits(bngdigit d)
+{
+  int n = BNG_BITS_PER_DIGIT;
+#ifdef ARCH_SIXTYFOUR
+  if ((d & 0xFFFFFFFF00000000L) != 0) { n -= 32; d = d >> 32; }
+#endif
+  if ((d & 0xFFFF0000) != 0) { n -= 16; d = d >> 16; }
+  if ((d & 0xFF00) != 0) { n -= 8; d = d >> 8; }
+  if ((d & 0xF0) != 0) { n -= 4; d = d >> 4; }
+  if ((d & 0xC) != 0) { n -= 2; d = d >> 2; }
+  if ((d & 2) != 0) { n -= 1; d = d >> 1; }
+  return n - d;
+}
+
+/* Complement the digits of {a,len} */
+void bng_complement(bng a/*[alen]*/, bngsize alen)
+{
+  for (/**/; alen > 0; alen--, a++) *a = ~*a;
+}
+
+/* Return number of significant digits in {a,alen}. */
+bngsize bng_num_digits(bng a/*[alen]*/, bngsize alen)
+{
+  while (1) {
+    if (alen == 0) return 1;
+    if (a[alen - 1] != 0) return alen;
+    alen--;
+  }
+}
+
+/* Return 0 if {a,alen} = {b,blen}
+         -1 if {a,alen} < {b,blen}
+          1 if {a,alen} > {b,blen}. */
+int bng_compare(bng a/*[alen]*/, bngsize alen,
+                bng b/*[blen]*/, bngsize blen)
+{
+  bngdigit da, db;
+
+  while (alen > 0 && a[alen-1] == 0) alen--;
+  while (blen > 0 && b[blen-1] == 0) blen--;
+  if (alen > blen) return 1;
+  if (alen < blen) return -1;
+  while (alen > 0) {
+    alen--;
+    da = a[alen];
+    db = b[alen];
+    if (da > db) return 1;
+    if (da < db) return -1;
+  }
+  return 0;
+}
+
+/**** Generic definitions of the overridable operations ****/
+
+/* {a,alen} := {a, alen} + carry.  Return carry out. */
+static bngcarry bng_generic_add_carry
+       (bng a/*[alen]*/,  bngsize alen, bngcarry carry)
+{
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if (++(*a) != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+/* {a,alen} := {a,alen} + {b,blen} + carry.  Return carry out.
+   Require alen >= blen. */
+static bngcarry bng_generic_add
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngcarry carry)
+{
+  alen -= blen;
+  for (/**/; blen > 0; blen--, a++, b++) {
+    BngAdd2Carry(*a, carry, *a, *b, carry);
+  }
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if (++(*a) != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+/* {a,alen} := {a, alen} - carry.  Return carry out. */
+static bngcarry bng_generic_sub_carry
+       (bng a/*[alen]*/,  bngsize alen, bngcarry carry)
+{
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if ((*a)-- != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+/* {a,alen} := {a,alen} - {b,blen} - carry.  Return carry out.
+   Require alen >= blen. */
+static bngcarry bng_generic_sub
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngcarry carry)
+{
+  alen -= blen;
+  for (/**/; blen > 0; blen--, a++, b++) {
+    BngSub2Carry(*a, carry, *a, *b, carry);
+  }
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if ((*a)-- != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+/* {a,alen} := {a,alen} << shift.  
+   Return the bits shifted out of the most significant digit of a.
+   Require 0 <= shift < BITS_PER_BNGDIGIT. */
+static bngdigit bng_generic_shift_left
+     (bng a/*[alen]*/, bngsize alen,
+      int shift)
+{
+  int shift2 = BNG_BITS_PER_DIGIT - shift;
+  bngdigit carry = 0;
+  if (shift > 0) {
+    for (/**/; alen > 0; alen--, a++) {
+      bngdigit d = *a;
+      *a = (d << shift) | carry;
+      carry = d >> shift2;
+    }
+  }
+  return carry;
+}
+
+/* {a,alen} := {a,alen} >> shift.  
+   Return the bits shifted out of the least significant digit of a.
+   Require 0 <= shift < BITS_PER_BNGDIGIT. */
+static bngdigit bng_generic_shift_right
+     (bng a/*[alen]*/, bngsize alen,
+      int shift)
+{
+  int shift2 = BNG_BITS_PER_DIGIT - shift;
+  bngdigit carry = 0;
+  if (shift > 0) {
+    for (a = a + alen - 1; alen > 0; alen--, a--) {
+      bngdigit d = *a;
+      *a = (d >> shift) | carry;
+      carry = d << shift2;
+    }
+  }
+  return carry;
+}
+
+/* {a,alen} := {a,alen} + d * {b,blen}.  Return carry out.
+   Require alen >= blen. */
+static bngdigit bng_generic_mult_add_digit
+     (bng a/*[alen]*/, bngsize alen,
+      bng b/*[blen]*/, bngsize blen,
+      bngdigit d)
+{
+  bngdigit out, ph, pl;
+  bngcarry carry;
+
+  alen -= blen;
+  for (out = 0; blen > 0; blen--, a++, b++) {
+    bngdigit bd = *b;
+    /* ph:pl = double-digit product of b's current digit and d */
+    BngMult(ph, pl, bd, d);
+    /* current digit of a += pl + out.  Accumulate carries in ph. */
+    BngAdd3(*a, ph, *a, pl, out);
+    /* prepare out for next iteration */
+    out = ph;
+  }
+  if (alen == 0) return out;
+  /* current digit of a += out */
+  BngAdd2(*a, carry, *a, out);
+  a++;
+  alen--;
+  /* Propagate carry */
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if (++(*a) != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+/* {a,alen} := {a,alen} - d * {b,blen}.  Return carry out.
+   Require alen >= blen. */
+static bngdigit bng_generic_mult_sub_digit
+     (bng a/*[alen]*/, bngsize alen,
+      bng b/*[blen]*/, bngsize blen,
+      bngdigit d)
+{
+  bngdigit out, ph, pl;
+  bngcarry carry;
+
+  alen -= blen;
+  for (out = 0; blen > 0; blen--, a++, b++) {
+    bngdigit bd = *b;
+    /* ph:pl = double-digit product of b's current digit and d */
+    BngMult(ph, pl, bd, d);
+    /* current digit of a -= pl + out.  Accumulate carrys in ph. */
+    BngSub3(*a, ph, *a, pl, out);
+    /* prepare out for next iteration */
+    out = ph;
+  }
+  if (alen == 0) return out;
+  /* current digit of a -= out */
+  BngSub2(*a, carry, *a, out);
+  a++;
+  alen--;
+  /* Propagate carry */
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if ((*a)-- != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+/* {a,alen} := {a,alen} + {b,blen} * {c,clen}.  Return carry out.
+   Require alen >= blen + clen. */
+static bngcarry bng_generic_mult_add
+     (bng a/*[alen]*/, bngsize alen,
+      bng b/*[blen]*/, bngsize blen,
+      bng c/*[clen]*/, bngsize clen)
+{
+  bngcarry carry;
+  for (carry = 0; clen > 0; clen--, c++, alen--, a++)
+    carry += bng_mult_add_digit(a, alen, b, blen, *c);
+  return carry;
+}
+
+/* {a,alen} := 2 * {a,alen} + {b,blen}^2.  Return carry out.
+   Require alen >= 2 * blen. */
+static bngcarry bng_generic_square_add
+     (bng a/*[alen]*/, bngsize alen,
+      bng b/*[blen]*/, bngsize blen)
+{
+  bngcarry carry1, carry2;
+  bngsize i, aofs;
+  bngdigit ph, pl, d;
+
+  /* Double products */
+  for (carry1 = 0, i = 1; i < blen; i++) {
+    aofs = 2 * i - 1;
+    carry1 += bng_mult_add_digit(a + aofs, alen - aofs, 
+                                 b + i, blen - i, b[i - 1]);
+  }
+  /* Multiply by two */
+  carry1 = (carry1 << 1) | bng_shift_left(a, alen, 1);
+  /* Add square of digits */
+  carry2 = 0;
+  for (i = 0; i < blen; i++) {
+    d = b[i];
+    BngMult(ph, pl, d, d);
+    BngAdd2Carry(*a, carry2, *a, pl, carry2);
+    a++;
+    BngAdd2Carry(*a, carry2, *a, ph, carry2);
+    a++;
+  }
+  alen -= 2 * blen;
+  if (alen > 0 && carry2 != 0) {
+    do {
+      if (++(*a) != 0) { carry2 = 0; break; }
+      a++;
+    } while (--alen);
+  }
+  return carry1 + carry2;
+}
+
+/* {a,len-1} := {b,len} / d.  Return {b,len} modulo d.
+   Require MSD of b < d.
+   If BngDivNeedsNormalization is defined, require d normalized. */
+static bngdigit bng_generic_div_rem_norm_digit
+     (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d)
+{
+  bngdigit topdigit, quo, rem;
+  long i;
+
+  topdigit = b[len - 1];
+  for (i = len - 2; i >= 0; i--) {
+    /* Divide topdigit:current digit of numerator by d */
+    BngDiv(quo, rem, topdigit, b[i], d);
+    /* Quotient is current digit of result */
+    a[i] = quo;
+    /* Iterate with topdigit = remainder */
+    topdigit = rem;
+  }
+  return topdigit;
+}
+
+#ifdef BngDivNeedsNormalization
+/* {a,len-1} := {b,len} / d.  Return {b,len} modulo d.
+   Require MSD of b < d. */
+static bngdigit bng_generic_div_rem_digit
+     (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d)
+{
+  bngdigit rem;
+  int shift;
+
+  /* Normalize d and b */
+  shift = bng_leading_zero_bits(d);
+  d <<= shift;
+  bng_shift_left(b, len, shift);
+  /* Do the division */
+  rem = bng_div_rem_norm_digit(a, b, len, d);
+  /* Undo normalization on b and remainder */
+  bng_shift_right(b, len, shift);
+  return rem >> shift;
+}
+#endif
+
+/* {n+dlen, nlen-dlen} := {n,nlen} / {d, dlen}.
+   {n, dlen} := {n,nlen} modulo {d, dlen}.
+   Require nlen > dlen and MSD of n < MSD of d.
+   (This implies MSD of d > 0). */
+static void bng_generic_div_rem
+       (bng n/*[nlen]*/, bngsize nlen,
+        bng d/*[dlen]*/, bngsize dlen)
+{
+  bngdigit topden, quo, rem;
+  int shift;
+  bngsize i, j;
+
+  /* Normalize d */
+  shift = bng_leading_zero_bits(d[dlen - 1]);
+  /* Note that no bits of n are lost by the following shift,
+     since n[nlen-1] < d[dlen-1] */
+  bng_shift_left(n, nlen, shift);
+  bng_shift_left(d, dlen, shift);
+  /* Special case if d is just one digit */
+  if (dlen == 1) {
+    *n = bng_div_rem_norm_digit(n + 1, n, nlen, *d);
+  } else {
+    topden = d[dlen - 1];
+    /* Long division */
+    for (j = nlen - 1; j >= dlen; j--) {
+      i = j - dlen;
+      /* At this point:
+         - the current numerator is      n[j] : ...................... : n[0]
+         - to be subtracted quo times:   d[dlen-1] : ... : d[0] : 0... : 0
+         (there are i zeroes at the end) */
+      /* Under-estimate the next digit of the quotient (quo) */
+      if (topden + 1 == 0)
+        quo = n[j];
+      else
+        BngDiv(quo, rem, n[j], n[j - 1], topden + 1);
+      /* Subtract d * quo (shifted i places) from numerator */
+      n[j] -= bng_mult_sub_digit(n + i, dlen, d, dlen, quo);
+      /* Adjust if necessary */
+      while (n[j] != 0 || bng_compare(n + i, dlen, d, dlen) >= 0) {
+        /* Numerator is still bigger than shifted divisor.
+           Increment quotient and subtract shifted divisor. */
+        quo++;
+        n[j] -= bng_sub(n + i, dlen, d, dlen, 0);
+      }
+      /* Store quotient digit */
+      n[j] = quo;
+    }
+  }
+  /* Undo normalization on remainder and divisor */
+  bng_shift_right(n, dlen, shift);
+  bng_shift_right(d, dlen, shift);
+}
+
+/**** Construction of the table of operations ****/
+
+struct bng_operations bng_ops = {
+  bng_generic_add_carry,
+  bng_generic_add,
+  bng_generic_sub_carry,
+  bng_generic_sub,
+  bng_generic_shift_left,
+  bng_generic_shift_right,
+  bng_generic_mult_add_digit,
+  bng_generic_mult_sub_digit,
+  bng_generic_mult_add,
+  bng_generic_square_add,
+  bng_generic_div_rem_norm_digit,
+#ifdef BngDivNeedsNormalization
+  bng_generic_div_rem_digit,
+#else
+  bng_generic_div_rem_norm_digit,
+#endif
+  bng_generic_div_rem
+};
+  
+void bng_init(void)
+{
+#ifdef BNG_SETUP_OPS
+  BNG_SETUP_OPS;
+#endif
+}
diff --git a/otherlibs/num/bng.h b/otherlibs/num/bng.h
new file mode 100644
index 00000000..6e51bb53
--- /dev/null
+++ b/otherlibs/num/bng.h
@@ -0,0 +1,156 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: bng.h,v 1.2 2003/11/07 07:59:09 xleroy Exp $ */
+
+#include <string.h>
+
+typedef unsigned long bngdigit;
+typedef bngdigit * bng;
+typedef unsigned int bngcarry;
+typedef unsigned long bngsize;
+
+#define BNG_BITS_PER_DIGIT (sizeof(bngdigit) * 8)
+#define BNG_BITS_PER_HALF_DIGIT (sizeof(bngdigit) * 4)
+
+struct bng_operations {
+
+  /* {a,alen} := {a, alen} + carry.  Return carry out. */
+  bngcarry (*add_carry)
+       (bng a/*[alen]*/,  bngsize alen, bngcarry carry);
+#define bng_add_carry bng_ops.add_carry
+
+  /* {a,alen} := {a,alen} + {b,blen} + carry.  Return carry out.
+     Require alen >= blen. */
+  bngcarry (*add)
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngcarry carry);
+#define bng_add bng_ops.add
+
+  /* {a,alen} := {a, alen} - carry.  Return carry out. */
+  bngcarry (*sub_carry)
+       (bng a/*[alen]*/,  bngsize alen, bngcarry carry);
+#define bng_sub_carry bng_ops.sub_carry
+
+  /* {a,alen} := {a,alen} - {b,blen} - carry.  Return carry out.
+     Require alen >= blen. */
+  bngcarry (*sub)
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngcarry carry);
+#define bng_sub bng_ops.sub
+
+  /* {a,alen} := {a,alen} << shift.  
+     Return the bits shifted out of the most significant digit of a.
+     Require 0 <= shift < BITS_PER_BNGDIGIT. */
+  bngdigit (*shift_left)
+       (bng a/*[alen]*/, bngsize alen,
+        int shift);
+#define bng_shift_left bng_ops.shift_left
+
+  /* {a,alen} := {a,alen} >> shift.  
+     Return the bits shifted out of the least significant digit of a.
+     Require 0 <= shift < BITS_PER_BNGDIGIT. */
+  bngdigit (*shift_right)
+       (bng a/*[alen]*/, bngsize alen,
+        int shift);
+#define bng_shift_right bng_ops.shift_right
+
+  /* {a,alen} := {a,alen} + d * {b,blen}.  Return carry out.
+     Require alen >= blen.
+     If alen > blen, the carry out returned is 0 or 1.
+     If alen == blen, the carry out returned is a full digit. */
+  bngdigit (*mult_add_digit)
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngdigit d);
+#define bng_mult_add_digit bng_ops.mult_add_digit
+
+  /* {a,alen} := {a,alen} - d * {b,blen}.  Return carry out.
+     Require alen >= blen.
+     If alen > blen, the carry out returned is 0 or 1.
+     If alen == blen, the carry out returned is a full digit. */
+  bngdigit (*mult_sub_digit)
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngdigit d);
+#define bng_mult_sub_digit bng_ops.mult_sub_digit
+
+  /* {a,alen} := {a,alen} + {b,blen} * {c,clen}.  Return carry out.
+     Require alen >= blen + clen. */
+  bngcarry (*mult_add)
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bng c/*[clen]*/, bngsize clen);
+#define bng_mult_add bng_ops.mult_add
+
+  /* {a,alen} := 2 * {a,alen} + {b,blen}^2.  Return carry out.
+     Require alen >= 2 * blen. */
+  bngcarry (*square_add)
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen);
+#define bng_square_add bng_ops.square_add
+
+  /* {a,len-1} := {b,len} / d.  Return {b,len} modulo d.
+     Require d is normalized and MSD of b < d.
+     See div_rem_digit for a function that does not require d
+     to be normalized */
+  bngdigit (*div_rem_norm_digit)
+       (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d);
+#define bng_div_rem_norm_digit bng_ops.div_rem_norm_digit
+
+  /* {a,len-1} := {b,len} / d.  Return {b,len} modulo d.
+     Require MSD of b < d. */
+     bngdigit (*div_rem_digit)
+       (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d);
+#define bng_div_rem_digit bng_ops.div_rem_digit
+
+  /* {n+dlen, nlen-dlen} := {n,nlen} / {d, dlen}.
+     {n, dlen} := {n,nlen} modulo {d, dlen}.
+     Require nlen > dlen and MSD of n < MSD of d (which implies d != 0). */
+  void (*div_rem)
+       (bng n/*[nlen]*/, bngsize nlen,
+        bng d/*[nlen]*/, bngsize dlen);
+#define bng_div_rem bng_ops.div_rem
+};
+
+extern struct bng_operations bng_ops;
+
+/* Initialize the BNG library */
+extern void bng_init(void);
+
+/* {a,alen} := 0 */
+#define bng_zero(a,alen) memset((a), 0, (alen) * sizeof(bngdigit))
+
+/* {a,len} := {b,len} */
+#define bng_assign(a,b,len) memmove((a), (b), (len) * sizeof(bngdigit))
+
+/* Complement the digits of {a,len} */
+extern void bng_complement(bng a/*[alen]*/, bngsize alen);
+
+/* Return number of significant digits in {a,alen}. */
+extern bngsize bng_num_digits(bng a/*[alen]*/, bngsize alen);
+
+/* Return 1 if {a,alen} is 0, 0 otherwise. */
+#define bng_is_zero(a,alen) (bng_num_digits(a,alen) == 0)
+
+/* Return 0 if {a,alen} = {b,blen}
+         <0 if {a,alen} < {b,blen}
+         >0 if {a,alen} > {b,blen}. */
+extern int bng_compare(bng a/*[alen]*/, bngsize alen,
+                       bng b/*[blen]*/, bngsize blen);
+
+/* Return the number of leading zero bits in digit d. */
+extern int bng_leading_zero_bits(bngdigit d);
+
diff --git a/maccaml/clipboard.c b/otherlibs/num/bng_alpha.c
similarity index 51%
rename from maccaml/clipboard.c
rename to otherlibs/num/bng_alpha.c
index c66f91e5..94168a38 100644
--- a/maccaml/clipboard.c
+++ b/otherlibs/num/bng_alpha.c
@@ -2,39 +2,22 @@
 /*                                                                     */
 /*                           Objective Caml                            */
 /*                                                                     */
-/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
-/*  Copyright 1998 Institut National de Recherche en Informatique et   */
+/*  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.     */
+/*  the special exception on linking described in file ../../LICENSE.  */
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: clipboard.c,v 1.3 2001/12/07 13:39:45 xleroy Exp $ */
+/* $Id: bng_alpha.c,v 1.1 2003/10/24 09:17:32 xleroy Exp $ */
 
-#include "main.h"
+/* Code specific to the Alpha architecture. */
 
-WindowPtr clip_window = NULL;
+#define BngMult(resh,resl,arg1,arg2)                                        \
+  asm("mulq %2, %3, %0 \n\t"                                                \
+      "umulh %2, %3, %1"                                                    \
+      : "=&r" (resl), "=r" (resh)                                           \
+      : "r" (arg1), "r" (arg2))
 
-/* 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/otherlibs/num/bng_amd64.c b/otherlibs/num/bng_amd64.c
new file mode 100644
index 00000000..85ee15e4
--- /dev/null
+++ b/otherlibs/num/bng_amd64.c
@@ -0,0 +1,196 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: bng_amd64.c,v 1.1 2003/10/24 09:17:33 xleroy Exp $ */
+
+/* Code specific to the AMD x86_64 architecture. */
+
+#define BngAdd2(res,carryout,arg1,arg2)                                     \
+  asm("xorl %1, %1 \n\t"                                                    \
+      "addq %3, %0 \n\t"                                                    \
+      "setc %b1"                                                            \
+      : "=r" (res), "=&q" (carryout)                                        \
+      : "0" (arg1), "rm" (arg2))
+
+#define BngSub2(res,carryout,arg1,arg2)                                     \
+  asm("xorl %1, %1 \n\t"                                                    \
+      "subq %3, %0 \n\t"                                                    \
+      "setc %b1"                                                            \
+      : "=r" (res), "=&q" (carryout)                                        \
+      : "0" (arg1), "rm" (arg2))
+
+#define BngMult(resh,resl,arg1,arg2)                                        \
+  asm("mulq %3"                                                             \
+      : "=a" (resl), "=d" (resh)                                            \
+      : "a" (arg1), "r" (arg2))
+
+#define BngDiv(quo,rem,nh,nl,d)                                             \
+  asm("divq %4"                                                             \
+      : "=a" (quo), "=d" (rem)                                              \
+      : "a" (nl), "d" (nh), "r" (d))
+
+/* Reimplementation in asm of some of the bng operations. */
+
+static bngcarry bng_amd64_add
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngcarry carry)
+{
+  bngdigit tmp;
+  alen -= blen;
+  if (blen > 0) {
+    asm("negb %b3 \n\t"
+        "1: \n\t"
+        "movq (%0), %4 \n\t"
+        "adcq (%1), %4 \n\t"
+        "movq %4, (%0) \n\t"
+        "leaq 8(%0), %0 \n\t"
+        "leaq 8(%1), %1 \n\t"
+        "decq %2 \n\t"
+        "jnz 1b \n\t"
+        "setc %b3"
+        : "=r" (a), "=r" (b), "=r" (blen), "=q" (carry), "=r" (tmp)
+        : "0" (a), "1" (b), "2" (blen), "3" (carry));
+  }
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if (++(*a) != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+static bngcarry bng_amd64_sub
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngcarry carry)
+{
+  bngdigit tmp;
+  alen -= blen;
+  if (blen > 0) {
+    asm("negb %b3 \n\t"
+        "1: \n\t"
+        "movq (%0), %4 \n\t"
+        "sbbq (%1), %4 \n\t"
+        "movq %4, (%0) \n\t"
+        "leaq 8(%0), %0 \n\t"
+        "leaq 8(%1), %1 \n\t"
+        "decq %2 \n\t"
+        "jnz 1b \n\t"
+        "setc %b3"
+        : "=r" (a), "=r" (b), "=r" (blen), "=q" (carry), "=r" (tmp)
+        : "0" (a), "1" (b), "2" (blen), "3" (carry));
+  }
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if ((*a)-- != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+static bngdigit bng_amd64_mult_add_digit
+     (bng a/*[alen]*/, bngsize alen,
+      bng b/*[blen]*/, bngsize blen,
+      bngdigit d)
+{
+  bngdigit out;
+  bngcarry carry;
+
+  alen -= blen;
+  out = 0;
+  if (blen > 0) {
+    asm("1: \n\t"
+        "movq (%1), %%rax \n\t"
+        "mulq %7\n\t"           /* rdx:rax = d * next digit of b */
+        "addq (%0), %%rax \n\t" /* add next digit of a to rax */
+        "adcq $0, %%rdx \n\t"   /* accumulate carry in rdx */
+        "addq %3, %%rax \n\t"   /* add out to rax */
+        "adcq $0, %%rdx \n\t"   /* accumulate carry in rdx */
+        "movq %%rax, (%0) \n\t" /* rax is next digit of result */
+        "movq %%rdx, %3 \n\t"   /* rdx is next out */
+        "leaq 8(%0), %0 \n\t"
+        "leaq 8(%1), %1 \n\t"
+        "decq %2 \n\t"
+        "jnz 1b"
+        : "=&r" (a), "=&r" (b), "=&r" (blen), "=&r" (out)
+        : "0" (a), "1" (b), "2" (blen), "rm" (d), "3" (out)
+        : "rax", "rdx");
+  }
+  if (alen == 0) return out;
+  /* current digit of a += out */
+  BngAdd2(*a, carry, *a, out);
+  a++;
+  alen--;
+  /* Propagate carry */
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if (++(*a) != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+static bngdigit bng_amd64_mult_sub_digit
+     (bng a/*[alen]*/, bngsize alen,
+      bng b/*[blen]*/, bngsize blen,
+      bngdigit d)
+{
+  bngdigit out, tmp;
+  bngcarry carry;
+
+  alen -= blen;
+  out = 0;
+  if (blen > 0) {
+    asm("1: \n\t"
+        "movq (%1), %%rax \n\t"
+        "movq (%0), %4 \n\t"
+        "mulq %8\n\t"           /* rdx:rax = d * next digit of b */
+        "subq %%rax, %4 \n\t"   /* subtract rax from next digit of a */
+        "adcq $0, %%rdx \n\t"   /* accumulate carry in rdx */
+        "subq %3, %4 \n\t"      /* subtract out */
+        "adcq $0, %%rdx \n\t"   /* accumulate carry in rdx */
+        "movq %4, (%0) \n\t"    /* store next digit of result */
+        "movq %%rdx, %3 \n\t"   /* rdx is next out */
+        "leaq 8(%0), %0 \n\t"
+        "leaq 8(%1), %1 \n\t"
+        "decq %2 \n\t"
+        "jnz 1b"
+        : "=&r" (a), "=&r" (b), "=&rm" (blen), "=&r" (out), "=&r" (tmp)
+        : "0" (a), "1" (b), "2" (blen), "rm" (d), "3" (out)
+        : "rax", "rdx");
+  }
+  if (alen == 0) return out;
+  /* current digit of a -= out */
+  BngSub2(*a, carry, *a, out);
+  a++;
+  alen--;
+  /* Propagate carry */
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if ((*a)-- != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+static void bng_amd64_setup_ops(void)
+{
+  bng_ops.add = bng_amd64_add;
+  bng_ops.sub = bng_amd64_sub;
+  bng_ops.mult_add_digit = bng_amd64_mult_add_digit;
+  bng_ops.mult_sub_digit = bng_amd64_mult_sub_digit;
+}
+
+#define BNG_SETUP_OPS bng_amd64_setup_ops()
+
diff --git a/otherlibs/num/bng_digit.c b/otherlibs/num/bng_digit.c
new file mode 100644
index 00000000..0095b439
--- /dev/null
+++ b/otherlibs/num/bng_digit.c
@@ -0,0 +1,171 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: bng_digit.c,v 1.1 2003/10/24 09:17:33 xleroy Exp $ */
+
+/**** Generic operations on digits ****/
+
+/* These macros can be defined in the machine-specific include file.
+   Below are the default definitions (in plain C).
+   Except for BngMult, all macros are guaranteed to evaluate their
+   arguments exactly once. */
+
+#ifndef BngAdd2
+/* res = arg1 + arg2.  carryout = carry out. */
+#define BngAdd2(res,carryout,arg1,arg2) {                                   \
+  bngdigit tmp1, tmp2;                                                      \
+  tmp1 = arg1;                                                              \
+  tmp2 = tmp1 + (arg2);                                                     \
+  carryout = (tmp2 < tmp1);                                                 \
+  res = tmp2;                                                               \
+}
+#endif
+
+#ifndef BngAdd2Carry
+/* res = arg1 + arg2 + carryin.  carryout = carry out. */
+#define BngAdd2Carry(res,carryout,arg1,arg2,carryin) {                      \
+  bngdigit tmp1, tmp2, tmp3;                                                \
+  tmp1 = arg1;                                                              \
+  tmp2 = tmp1 + (arg2);                                                     \
+  tmp3 = tmp2 + (carryin);                                                  \
+  carryout = (tmp2 < tmp1) + (tmp3 < tmp2);                                 \
+  res = tmp3;                                                               \
+}
+#endif
+
+#ifndef BngAdd3
+/* res = arg1 + arg2 + arg3.  Each carry increments carryaccu. */
+#define BngAdd3(res,carryaccu,arg1,arg2,arg3) {                             \
+  bngdigit tmp1, tmp2, tmp3;                                                \
+  tmp1 = arg1;                                                              \
+  tmp2 = tmp1 + (arg2);                                                     \
+  carryaccu += (tmp2 < tmp1);                                               \
+  tmp3 = tmp2 + (arg3);                                                     \
+  carryaccu += (tmp3 < tmp2);                                               \
+  res = tmp3;                                                               \
+}
+#endif
+
+#ifndef BngSub2
+/* res = arg1 - arg2.  carryout = carry out. */
+#define BngSub2(res,carryout,arg1,arg2) {                                   \
+  bngdigit tmp1, tmp2;                                                      \
+  tmp1 = arg1;                                                              \
+  tmp2 = arg2;                                                              \
+  res = tmp1 - tmp2;                                                        \
+  carryout = (tmp1 < tmp2);                                                 \
+}
+#endif
+
+#ifndef BngSub2Carry
+/* res = arg1 - arg2 - carryin.  carryout = carry out. */
+#define BngSub2Carry(res,carryout,arg1,arg2,carryin) {                      \
+  bngdigit tmp1, tmp2, tmp3;                                                \
+  tmp1 = arg1;                                                              \
+  tmp2 = arg2;                                                              \
+  tmp3 = tmp1 - tmp2;                                                       \
+  res = tmp3 - (carryin);                                                   \
+  carryout = (tmp1 < tmp2) + (tmp3 < carryin);                              \
+}
+#endif
+
+#ifndef BngSub3
+/* res = arg1 - arg2 - arg3.  Each carry increments carryaccu. */
+#define BngSub3(res,carryaccu,arg1,arg2,arg3) {                             \
+  bngdigit tmp1, tmp2, tmp3, tmp4;                                          \
+  tmp1 = arg1;                                                              \
+  tmp2 = arg2;                                                              \
+  tmp3 = arg3;                                                              \
+  tmp4 = tmp1 - tmp2;                                                       \
+  res = tmp4 - tmp3;                                                        \
+  carryaccu += (tmp1 < tmp2) + (tmp4 < tmp3);                               \
+}
+#endif
+
+#define BngLowHalf(d) ((d) & ((1L << BNG_BITS_PER_HALF_DIGIT) - 1))
+#define BngHighHalf(d) ((d) >> BNG_BITS_PER_HALF_DIGIT)
+
+#ifndef BngMult
+/* resl = low  digit of product arg1 * arg2
+   resh = high digit of product arg1 * arg2. */
+#define BngMult(resh,resl,arg1,arg2) {                                      \
+  bngdigit p11 = BngLowHalf(arg1) * BngLowHalf(arg2);                       \
+  bngdigit p12 = BngLowHalf(arg1) * BngHighHalf(arg2);                      \
+  bngdigit p21 = BngHighHalf(arg1) * BngLowHalf(arg2);                      \
+  bngdigit p22 = BngHighHalf(arg1) * BngHighHalf(arg2);                     \
+  resh = p22 + (p12 >> BNG_BITS_PER_HALF_DIGIT)                             \
+             + (p21 >> BNG_BITS_PER_HALF_DIGIT);                            \
+  BngAdd3(resl, resh,                                                       \
+     p11, p12 << BNG_BITS_PER_HALF_DIGIT, p21 << BNG_BITS_PER_HALF_DIGIT);  \
+}
+#endif
+
+#ifndef BngDiv
+/* Divide the double-width number nh:nl by d.
+   Require d != 0 and nh < d.
+   Store quotient in quo, remainder in rem.
+   Can be slow if d is not normalized. */
+#define BngDiv(quo,rem,nh,nl,d) bng_div_aux(&(quo),&(rem),nh,nl,d)
+#define BngDivNeedsNormalization
+
+static void bng_div_aux(bngdigit * quo, bngdigit * rem,
+                        bngdigit nh, bngdigit nl, bngdigit d)
+{
+  bngdigit dl, dh, ql, qh, pl, ph, nsaved;
+
+  dl = BngLowHalf(d);
+  dh = BngHighHalf(d);
+  /* Under-estimate the top half of the quotient (qh) */
+  qh = nh / (dh + 1);
+  /* Shift nh:nl right by BNG_BITS_PER_HALF_DIGIT bits,
+     so that we focus on the top 1.5 digits of the numerator.
+     Then, subtract (qh * d) from nh:nl. */
+  nsaved = BngLowHalf(nl);
+  ph = qh * dh;
+  pl = qh * dl;
+  nh -= ph; /* Subtract before shifting so that carry propagates for free */
+  nl = (nl >> BNG_BITS_PER_HALF_DIGIT) | (nh << BNG_BITS_PER_HALF_DIGIT);
+  nh = (nh >> BNG_BITS_PER_HALF_DIGIT);
+  nh -= (nl < pl);  /* Borrow */
+  nl -= pl;
+  /* Adjust estimate qh until nh:nl < 0:d */
+  while (nh != 0 || nl >= d) {
+    nh -= (nl < d); /* Borrow */
+    nl -= d;
+    qh++;
+  }
+  /* Under-estimate the bottom half of the quotient (ql) */
+  ql = nl / (dh + 1);
+  /* Shift nh:nl left by BNG_BITS_PER_HALF_DIGIT bits, restoring the
+     low bits we saved earlier, so that we focus on the bottom 1.5 digit
+     of the numerator.  Then, subtract (ql * d) from nh:nl. */
+  ph = ql * dh;
+  pl = ql * dl;
+  nl -= ph; /* Subtract before shifting so that carry propagates for free */
+  nh = (nl >> BNG_BITS_PER_HALF_DIGIT);
+  nl = (nl << BNG_BITS_PER_HALF_DIGIT) | nsaved;
+  nh -= (nl < pl);  /* Borrow */
+  nl -= pl;
+  /* Adjust estimate ql until nh:nl < 0:d */
+  while (nh != 0 || nl >= d) {
+    nh -= (nl < d); /* Borrow */
+    nl -= d;
+    ql++;
+  }
+  /* We're done */
+  *quo = (qh << BNG_BITS_PER_HALF_DIGIT) | ql;
+  *rem = nl;
+}
+
+#endif
+
diff --git a/otherlibs/num/bng_ia32.c b/otherlibs/num/bng_ia32.c
new file mode 100644
index 00000000..03e5ae9d
--- /dev/null
+++ b/otherlibs/num/bng_ia32.c
@@ -0,0 +1,412 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: bng_ia32.c,v 1.3 2003/10/26 09:51:11 xleroy Exp $ */
+
+/* Code specific to the Intel IA32 (x86) architecture. */
+
+#define BngAdd2(res,carryout,arg1,arg2)                                     \
+  asm("xorl %1, %1 \n\t"                                                    \
+      "addl %3, %0 \n\t"                                                    \
+      "setc %b1"                                                            \
+      : "=r" (res), "=&q" (carryout)                                        \
+      : "0" (arg1), "rm" (arg2))
+
+#define BngSub2(res,carryout,arg1,arg2)                                     \
+  asm("xorl %1, %1 \n\t"                                                    \
+      "subl %3, %0 \n\t"                                                    \
+      "setc %b1"                                                            \
+      : "=r" (res), "=&q" (carryout)                                        \
+      : "0" (arg1), "rm" (arg2))
+
+#define BngMult(resh,resl,arg1,arg2)                                        \
+  asm("mull %3"                                                             \
+      : "=a" (resl), "=d" (resh)                                            \
+      : "a" (arg1), "r" (arg2))
+
+#define BngDiv(quo,rem,nh,nl,d)                                             \
+  asm("divl %4"                                                             \
+      : "=a" (quo), "=d" (rem)                                              \
+      : "a" (nl), "d" (nh), "r" (d))
+
+/* Reimplementation in asm of some of the bng operations. */
+
+static bngcarry bng_ia32_add
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngcarry carry)
+{
+  bngdigit tmp;
+  alen -= blen;
+  if (blen > 0) {
+    asm("negb %b3 \n\t"
+        "1: \n\t"
+        "movl (%0), %4 \n\t"
+        "adcl (%1), %4 \n\t"
+        "movl %4, (%0) \n\t"
+        "leal 4(%0), %0 \n\t"
+        "leal 4(%1), %1 \n\t"
+        "decl %2 \n\t"
+        "jnz 1b \n\t"
+        "setc %b3"
+        : "+&r" (a), "+&r" (b), "+&r" (blen), "+&q" (carry), "=&r" (tmp));
+  }
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if (++(*a) != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+static bngcarry bng_ia32_sub
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngcarry carry)
+{
+  bngdigit tmp;
+  alen -= blen;
+  if (blen > 0) {
+    asm("negb %b3 \n\t"
+        "1: \n\t"
+        "movl (%0), %4 \n\t"
+        "sbbl (%1), %4 \n\t"
+        "movl %4, (%0) \n\t"
+        "leal 4(%0), %0 \n\t"
+        "leal 4(%1), %1 \n\t"
+        "decl %2 \n\t"
+        "jnz 1b \n\t"
+        "setc %b3"
+        : "+&r" (a), "+&r" (b), "+&r" (blen), "+&q" (carry), "=&r" (tmp));
+  }
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if ((*a)-- != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+static bngdigit bng_ia32_mult_add_digit
+     (bng a/*[alen]*/, bngsize alen,
+      bng b/*[blen]*/, bngsize blen,
+      bngdigit d)
+{
+  bngdigit out;
+  bngcarry carry;
+
+  alen -= blen;
+  out = 0;
+  if (blen > 0) {
+    asm("1: \n\t"
+        "movl (%1), %%eax \n\t"
+        "mull %4\n\t"           /* edx:eax = d * next digit of b */
+        "addl (%0), %%eax \n\t" /* add next digit of a to eax */
+        "adcl $0, %%edx \n\t"   /* accumulate carry in edx */
+        "addl %3, %%eax \n\t"   /* add out to eax */
+        "adcl $0, %%edx \n\t"   /* accumulate carry in edx */
+        "movl %%eax, (%0) \n\t" /* eax is next digit of result */
+        "movl %%edx, %3 \n\t"   /* edx is next out */
+        "leal 4(%0), %0 \n\t"
+        "leal 4(%1), %1 \n\t"
+        "decl %2 \n\t"
+        "jnz 1b"
+        : "+&r" (a), "+&r" (b), "+&rm" (blen), "+&r" (out)
+        : "rm" (d)
+        : "eax", "edx");
+  }
+  if (alen == 0) return out;
+  /* current digit of a += out */
+  BngAdd2(*a, carry, *a, out);
+  a++;
+  alen--;
+  /* Propagate carry */
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if (++(*a) != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+static bngdigit bng_ia32_mult_sub_digit
+     (bng a/*[alen]*/, bngsize alen,
+      bng b/*[blen]*/, bngsize blen,
+      bngdigit d)
+{
+  bngdigit out, tmp;
+  bngcarry carry;
+
+  alen -= blen;
+  out = 0;
+  if (blen > 0) {
+    asm("1: \n\t"
+        "movl (%1), %%eax \n\t"
+        "movl (%0), %4 \n\t"
+        "mull %5\n\t"           /* edx:eax = d * next digit of b */
+        "subl %%eax, %4 \n\t"   /* subtract eax from next digit of a */
+        "adcl $0, %%edx \n\t"   /* accumulate carry in edx */
+        "subl %3, %4 \n\t"      /* subtract out */
+        "adcl $0, %%edx \n\t"   /* accumulate carry in edx */
+        "movl %4, (%0) \n\t"    /* store next digit of result */
+        "movl %%edx, %3 \n\t"   /* edx is next out */
+        "leal 4(%0), %0 \n\t"
+        "leal 4(%1), %1 \n\t"
+        "decl %2 \n\t"
+        "jnz 1b"
+        : "+&r" (a), "+&r" (b), "+&rm" (blen), "+&rm" (out), "=&r" (tmp)
+        : "rm" (d)
+        : "eax", "edx");
+  }
+  if (alen == 0) return out;
+  /* current digit of a -= out */
+  BngSub2(*a, carry, *a, out);
+  a++;
+  alen--;
+  /* Propagate carry */
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if ((*a)-- != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+/* This is another asm implementation of some of the bng operations,
+   using SSE2 operations to provide 64-bit arithmetic.
+   This is faster than the plain IA32 code above on the Pentium 4.
+   (Arithmetic operations with carry are slow on the Pentium 4). */
+
+#if BNG_ASM_LEVEL >= 2
+
+static bngcarry bng_ia32sse2_add
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngcarry carry)
+{
+  alen -= blen;
+  if (blen > 0) {
+    asm("movd %3, %%mm0 \n\t"       /* MM0 is carry */
+        "1: \n\t"
+        "movd (%0), %%mm1 \n\t"     /* MM1 is next digit of a */
+        "movd (%1), %%mm2 \n\t"     /* MM2 is next digit of b */
+        "paddq %%mm1, %%mm0 \n\t"   /* Add carry (64 bits) */
+        "paddq %%mm2, %%mm0 \n\t"   /* Add digits (64 bits) */
+        "movd %%mm0, (%0) \n\t"     /* Store low 32 bits of result */
+        "psrlq $32, %%mm0 \n\t"     /* Next carry is top 32 bits of results */
+        "addl $4, %0\n\t"
+        "addl $4, %1\n\t"
+        "subl $1, %2\n\t"
+        "jne 1b \n\t"
+        "movd %%mm0, %3 \n\t"
+        "emms"
+        : "+&r" (a), "+&r" (b), "+&r" (blen), "+&rm" (carry));
+  }
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if (++(*a) != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+static bngcarry bng_ia32sse2_sub
+       (bng a/*[alen]*/, bngsize alen,
+        bng b/*[blen]*/, bngsize blen,
+        bngcarry carry)
+{
+  alen -= blen;
+  if (blen > 0) {
+    asm("movd %3, %%mm0 \n\t"       /* MM0 is carry */
+        "1: \n\t"
+        "movd (%0), %%mm1 \n\t"     /* MM1 is next digit of a */
+        "movd (%1), %%mm2 \n\t"     /* MM2 is next digit of b */
+        "psubq %%mm0, %%mm1 \n\t"   /* Subtract carry (64 bits) */
+        "psubq %%mm2, %%mm1 \n\t"   /* Subtract digits (64 bits) */
+        "movd %%mm1, (%0) \n\t"     /* Store low 32 bits of result */
+        "psrlq $63, %%mm1 \n\t"     /* Next carry is sign bit of result */
+        "movq %%mm1, %%mm0 \n\t"
+        "addl $4, %0\n\t"
+        "addl $4, %1\n\t"
+        "subl $1, %2\n\t"
+        "jne 1b \n\t"
+        "movd %%mm0, %3 \n\t"
+        "emms"
+        : "+&r" (a), "+&r" (b), "+&r" (blen), "+&rm" (carry));
+  }
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if ((*a)-- != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+static bngdigit bng_ia32sse2_mult_add_digit
+     (bng a/*[alen]*/, bngsize alen,
+      bng b/*[blen]*/, bngsize blen,
+      bngdigit d)
+{
+  bngdigit out;
+  bngcarry carry;
+
+  alen -= blen;
+  out = 0;
+  if (blen > 0) {
+    asm("pxor %%mm0, %%mm0 \n\t"      /* MM0 is carry */
+        "movd %4, %%mm7 \n\t"         /* MM7 is digit d */
+        "1: \n\t"
+        "movd (%0), %%mm1 \n\t"       /* MM1 is next digit of a */
+        "movd (%1), %%mm2 \n\t"       /* MM2 is next digit of b */
+        "pmuludq %%mm7, %%mm2 \n\t"   /* MM2 = d * digit of b */
+        "paddq %%mm1, %%mm0 \n\t"     /* Add product and carry ... */
+        "paddq %%mm2, %%mm0 \n\t"     /* ... and digit of a */
+        "movd %%mm0, (%0) \n\t"       /* Store low 32 bits of result */
+        "psrlq $32, %%mm0 \n\t"       /* Next carry is high 32 bits result */
+        "addl $4, %0\n\t"
+        "addl $4, %1\n\t"
+        "subl $1, %2\n\t"
+        "jne 1b \n\t"
+        "movd %%mm0, %3 \n\t"
+        "emms"
+        : "+&r" (a), "+&r" (b), "+&r" (blen), "=&rm" (out)
+        : "m" (d));
+  }
+  if (alen == 0) return out;
+  /* current digit of a += out */
+  BngAdd2(*a, carry, *a, out);
+  a++;
+  alen--;
+  /* Propagate carry */
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if (++(*a) != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+static bngdigit bng_ia32sse2_mult_sub_digit
+     (bng a/*[alen]*/, bngsize alen,
+      bng b/*[blen]*/, bngsize blen,
+      bngdigit d)
+{
+  static unsigned long long bias1 = 0xFFFFFFFF00000000ULL - 0xFFFFFFFFULL;
+  static unsigned long bias2 = 0xFFFFFFFFUL;
+  bngdigit out;
+  bngcarry carry;
+
+  alen -= blen;
+  out = 0;
+  if (blen > 0) {
+    /* Carry C is represented by ENC(C) = 0xFFFFFFFF - C (one's complement) */
+    asm("movd %6, %%mm0 \n\t"         /* MM0 is carry (initially 0xFFFFFFFF) */
+        "movq %5, %%mm6 \n\t"         /* MM6 is magic constant bias1 */
+        "movd %4, %%mm7 \n\t"         /* MM7 is digit d */
+        "1: \n\t"
+        "movd (%0), %%mm1 \n\t"       /* MM1 is next digit of a */
+        "movd (%1), %%mm2 \n\t"       /* MM2 is next digit of b */
+        "paddq %%mm6, %%mm1 \n\t"     /* bias digit of a */
+        "pmuludq %%mm7, %%mm2 \n\t"   /* MM2 = d * digit of b */
+        /* Compute 
+           digit of a + ENC(carry) + 0xFFFFFFFF00000000 - 0xFFFFFFFF - product
+           = digit of a - carry + 0xFFFFFFFF00000000 - product
+           = digit of a - carry - productlow + (ENC(nextcarry) << 32) */
+        "psubq %%mm2, %%mm1 \n\t"
+        "paddq %%mm1, %%mm0 \n\t"
+        "movd %%mm0, (%0) \n\t"       /* Store low 32 bits of result */
+        "psrlq $32, %%mm0 \n\t"       /* Next carry is 32 high bits of result */
+        "addl $4, %0\n\t"
+        "addl $4, %1\n\t"
+        "subl $1, %2\n\t"
+        "jne 1b \n\t"
+        "movd %%mm0, %3 \n\t"
+        "emms"
+        : "+&r" (a), "+&r" (b), "+&r" (blen), "=&rm" (out)
+        : "m" (d), "m" (bias1), "m" (bias2));
+    out = ~out; /* Undo encoding on out digit */
+  }
+  if (alen == 0) return out;
+  /* current digit of a -= out */
+  BngSub2(*a, carry, *a, out);
+  a++;
+  alen--;
+  /* Propagate carry */
+  if (carry == 0 || alen == 0) return carry;
+  do {
+    if ((*a)-- != 0) return 0;
+    a++;
+  } while (--alen);
+  return 1;
+}
+
+/* Detect whether SSE2 instructions are supported */
+
+static int bng_ia32_sse2_supported(void)
+{
+  unsigned int flags, newflags, max_id, capabilities;
+
+#define EFLAG_CPUID 0x00200000
+#define CPUID_IDENTIFY 0
+#define CPUID_CAPABILITIES 1
+#define SSE2_CAPABILITY 26
+
+  /* Check if processor has CPUID instruction */
+  asm("pushfl \n\t"
+      "popl %0"
+      : "=r" (flags) : );
+  newflags = flags ^ EFLAG_CPUID;   /* CPUID detection flag */
+  asm("pushfl \n\t"
+      "pushl %1 \n\t"
+      "popfl \n\t"
+      "pushfl \n\t"
+      "popl %0 \n\t"
+      "popfl"
+      : "=r" (flags) : "r" (newflags));
+  /* If CPUID detection flag cannot be changed, CPUID instruction is not
+     available */
+  if ((flags & EFLAG_CPUID) != (newflags & EFLAG_CPUID)) return 0;
+  /* See if SSE2 extensions are supported */
+  asm("pushl %%ebx \n\t"        /* need to preserve %ebx for PIC */
+      "cpuid \n\t"
+      "popl %%ebx"
+      : "=a" (max_id) : "a" (CPUID_IDENTIFY): "ecx", "edx");
+  if (max_id < 1) return 0;
+  asm("pushl %%ebx \n\t"
+      "cpuid \n\t"
+      "popl %%ebx"
+      : "=d" (capabilities) : "a" (CPUID_CAPABILITIES) : "ecx");
+  return capabilities & (1 << SSE2_CAPABILITY);
+}
+
+#endif
+
+static void bng_ia32_setup_ops(void)
+{
+#if BNG_ASM_LEVEL >= 2
+  if (bng_ia32_sse2_supported()) {
+    bng_ops.add = bng_ia32sse2_add;
+    bng_ops.sub = bng_ia32sse2_sub;
+    bng_ops.mult_add_digit = bng_ia32sse2_mult_add_digit;
+    bng_ops.mult_sub_digit = bng_ia32sse2_mult_sub_digit;
+    return;
+  }
+#endif
+  bng_ops.add = bng_ia32_add;
+  bng_ops.sub = bng_ia32_sub;
+  bng_ops.mult_add_digit = bng_ia32_mult_add_digit;
+  bng_ops.mult_sub_digit = bng_ia32_mult_sub_digit;
+}
+
+#define BNG_SETUP_OPS bng_ia32_setup_ops()
+
diff --git a/otherlibs/num/bng_mips.c b/otherlibs/num/bng_mips.c
new file mode 100644
index 00000000..d49b0333
--- /dev/null
+++ b/otherlibs/num/bng_mips.c
@@ -0,0 +1,24 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: bng_mips.c,v 1.1 2003/10/24 09:17:33 xleroy Exp $ */
+
+/* Code specific to the MIPS architecture. */
+
+#define BngMult(resh,resl,arg1,arg2)                                        \
+  asm("multu %2, %3 \n\t"                                                   \
+      "mflo %0 \n\t"                                                        \
+      "mfhi %1"                                                             \
+      : "=r" (resl), "=r" (resh)                                            \
+      : "r" (arg1), "r" (arg2))
+
diff --git a/otherlibs/num/bng_ppc.c b/otherlibs/num/bng_ppc.c
new file mode 100644
index 00000000..3820f3fb
--- /dev/null
+++ b/otherlibs/num/bng_ppc.c
@@ -0,0 +1,86 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: bng_ppc.c,v 1.2 2003/10/27 08:41:46 xleroy Exp $ */
+
+/* Code specific to the PowerPC architecture. */
+
+#define BngAdd2(res,carryout,arg1,arg2)                                     \
+  asm("addc %0, %2, %3 \n\t"                                                \
+      "li %1, 0 \n\t"                                                       \
+      "addze %1, %1"                                                        \
+      : "=r" (res), "=r" (carryout)                                         \
+      : "r" (arg1), "r" (arg2))
+
+#define BngAdd2Carry(res,carryout,arg1,arg2,carryin)                        \
+  asm("addic %1, %4, -1 \n\t"                                               \
+      "adde %0, %2, %3 \n\t"                                                \
+      "li %1, 0 \n\t"                                                       \
+      "addze %1, %1"                                                        \
+      : "=r" (res), "=&r" (carryout)                                        \
+      : "r" (arg1), "r" (arg2), "1" (carryin))
+
+#define BngAdd3(res,carryaccu,arg1,arg2,arg3)                               \
+  asm("addc %0, %2, %3 \n\t"                                                \
+      "addze %1, %1 \n\t"                                                   \
+      "addc %0, %0, %4 \n\t"                                                \
+      "addze %1, %1"                                                        \
+      : "=&r" (res), "=&r" (carryaccu)                                      \
+      : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu))
+
+/* The "subtract" instructions interpret carry differently than what we
+   need: the processor carry bit CA is 1 if no carry occured,
+   0 if a carry occured.  In other terms, CA = !carry.
+   Thus, subfe rd,ra,rb computes rd = ra - rb - !CA
+         subfe rd,rd,rd sets rd = - !CA
+         subfe rd,rd,rd; neg rd, rd sets rd = !CA and recovers "our" carry. */
+
+#define BngSub2(res,carryout,arg1,arg2)                                     \
+  asm("subfc %0, %3, %2 \n\t"                                               \
+      "subfe %1, %1, %1\n\t"                                                \
+      "neg %1, %1"                                                          \
+      : "=r" (res), "=r" (carryout)                                         \
+      : "r" (arg1), "r" (arg2))
+
+#define BngSub2Carry(res,carryout,arg1,arg2,carryin)                        \
+  asm("subfic %1, %4, 0 \n\t"                                               \
+      "subfe %0, %3, %2 \n\t"                                               \
+      "subfe %1, %1, %1 \n\t"                                               \
+      "neg %1, %1"                                                          \
+      : "=r" (res), "=&r" (carryout)                                        \
+      : "r" (arg1), "r" (arg2), "1" (carryin))
+
+/* Here is what happens with carryaccu:
+       neg %1, %1       carryaccu = -carryaccu
+       addze %1, %1     carryaccu += !carry1
+       addze %1, %1     carryaccu += !carry2
+       subifc %1, %1, 2 carryaccu = 2 - carryaccu
+   Thus, carryaccu_final = carryaccu_initial + 2 - (1 - carry1) - (1 - carry2)
+                         = carryaccu_initial + carry1 + carry2
+*/
+
+#define BngSub3(res,carryaccu,arg1,arg2,arg3)                               \
+  asm("neg %1, %1 \n\t"                                                     \
+      "subfc %0, %3, %2 \n\t"                                               \
+      "addze %1, %1 \n\t"                                                   \
+      "subfc %0, %4, %0 \n\t"                                               \
+      "addze %1, %1 \n\t"                                                   \
+      "subfic %1, %1, 2 \n\t"                                               \
+      : "=&r" (res), "=&r" (carryaccu)                                      \
+      : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu))
+
+#define BngMult(resh,resl,arg1,arg2)                                        \
+  asm("mullw %0, %2, %3 \n\t"                                               \
+      "mulhwu %1, %2, %3"                                                   \
+      : "=&r" (resl), "=r" (resh)                                           \
+      : "r" (arg1), "r" (arg2))
diff --git a/otherlibs/num/bng_sparc.c b/otherlibs/num/bng_sparc.c
new file mode 100644
index 00000000..eb750ae2
--- /dev/null
+++ b/otherlibs/num/bng_sparc.c
@@ -0,0 +1,77 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: bng_sparc.c,v 1.1 2003/10/24 09:17:34 xleroy Exp $ */
+
+/* Code specific to the SPARC (V8 and above) architecture. */
+
+#define BngAdd2(res,carryout,arg1,arg2)                                     \
+  asm("addcc %2, %3, %0 \n\t"                                               \
+      "addx  %%g0, 0, %1"                                                   \
+      : "=r" (res), "=r" (carryout)                                         \
+      : "r" (arg1), "r" (arg2)                                              \
+      : "cc")
+
+#define BngAdd2Carry(res,carryout,arg1,arg2,carryin)                        \
+  asm("subcc %%g0, %4, %%g0 \n\t"                                           \
+      "addxcc %2, %3, %0 \n\t"                                              \
+      "addx  %%g0, 0, %1"                                                   \
+      : "=r" (res), "=r" (carryout)                                         \
+      : "r" (arg1), "r" (arg2), "r" (carryin)                               \
+      : "cc")
+
+#define BngAdd3(res,carryaccu,arg1,arg2,arg3)                               \
+  asm("addcc %2, %3, %0 \n\t"                                               \
+      "addx %1, 0, %1 \n\t"                                                 \
+      "addcc %0, %4, %0 \n\t"                                               \
+      "addx %1, 0, %1"                                                      \
+      : "=r" (res), "=r" (carryaccu)                                        \
+      : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu)                 \
+      : "cc")
+
+#define BngSub2(res,carryout,arg1,arg2)                                     \
+  asm("subcc %2, %3, %0 \n\t"                                               \
+      "addx  %%g0, 0, %1"                                                   \
+      : "=r" (res), "=r" (carryout)                                         \
+      : "r" (arg1), "r" (arg2)                                              \
+      : "cc")
+
+#define BngSub2Carry(res,carryout,arg1,arg2,carryin)                        \
+  asm("subcc %%g0, %4, %%g0 \n\t"                                           \
+      "subxcc %2, %3, %0 \n\t"                                              \
+      "addx  %%g0, 0, %1"                                                   \
+      : "=r" (res), "=r" (carryout)                                         \
+      : "r" (arg1), "r" (arg2), "r" (carryin)                               \
+      : "cc")
+
+#define BngSub3(res,carryaccu,arg1,arg2,arg3)                               \
+  asm("subcc %2, %3, %0 \n\t"                                               \
+      "addx %1, 0, %1 \n\t"                                                 \
+      "subcc %0, %4, %0 \n\t"                                               \
+      "addx %1, 0, %1"                                                      \
+      : "=r" (res), "=r" (carryaccu)                                        \
+      : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu)                 \
+      : "cc")
+
+#define BngMult(resh,resl,arg1,arg2)                                        \
+  asm("umul %2, %3, %0 \n\t"                                                \
+      "rd %%y, %1"                                                          \
+      : "=r" (resl), "=r" (resh)                                            \
+      : "r" (arg1), "r" (arg2))
+
+#define BngDiv(quo,rem,nh,nl,d)                                             \
+  asm("wr %1, %%y \n\t"                                                     \
+      "udiv %2, %3, %0"                                                     \
+      : "=r" (quo)                                                          \
+      : "r" (nh), "r" (nl), "r" (d));                                       \
+  rem = nl - d * quo
diff --git a/otherlibs/num/int_misc.ml b/otherlibs/num/int_misc.ml
new file mode 100644
index 00000000..1c6f1b74
--- /dev/null
+++ b/otherlibs/num/int_misc.ml
@@ -0,0 +1,36 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: int_misc.ml,v 1.6 2002/05/27 12:06:49 weis Exp $ *)
+
+(* Some extra operations on integers *)
+
+let rec gcd_int i1 i2 =
+  if i2 = 0 then abs i1 else gcd_int i2 (i1 mod i2)
+;;
+
+let rec num_bits_int_aux n =
+  if n = 0 then 0 else succ(num_bits_int_aux (n lsr 1));;
+
+let num_bits_int n = num_bits_int_aux (abs n);;
+
+let sign_int i = if i = 0 then 0 else if i > 0 then 1 else -1;;
+
+let length_of_int = Sys.word_size - 2;;
+
+let monster_int = 1 lsl length_of_int;;
+let biggest_int = monster_int - 1;;
+let least_int = - biggest_int;;
+
+let compare_int n1 n2 =
+  if n1 == n2 then 0 else if n1 > n2 then 1 else -1;;
diff --git a/otherlibs/num/int_misc.mli b/otherlibs/num/int_misc.mli
new file mode 100644
index 00000000..a7b4e10a
--- /dev/null
+++ b/otherlibs/num/int_misc.mli
@@ -0,0 +1,25 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: int_misc.mli,v 1.4 2001/12/07 13:40:15 xleroy Exp $ *)
+
+(* Some extra operations on integers *)
+
+val gcd_int: int -> int -> int
+val num_bits_int: int -> int
+val compare_int: int -> int -> int
+val sign_int: int -> int
+val length_of_int: int
+val biggest_int: int
+val least_int: int
+val monster_int: int
diff --git a/maccaml/mcmisc.c b/otherlibs/num/nat.h
similarity index 63%
rename from maccaml/mcmisc.c
rename to otherlibs/num/nat.h
index 9e1b4416..d8988c7b 100644
--- a/maccaml/mcmisc.c
+++ b/otherlibs/num/nat.h
@@ -2,23 +2,18 @@
 /*                                                                     */
 /*                           Objective Caml                            */
 /*                                                                     */
-/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
-/*  Copyright 1998 Institut National de Recherche en Informatique et   */
+/*  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.     */
+/*  the special exception on linking described in file ../../LICENSE.  */
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: mcmisc.c,v 1.2 2001/12/07 13:39:47 xleroy Exp $ */
+/* $Id: nat.h,v 1.6 2003/10/24 09:17:34 xleroy Exp $ */
 
-#include "main.h"
+/* Nats are represented as unstructured blocks with tag Custom_tag. */
 
-void LocalToGlobalRect (Rect *r)
-{
-  Point *p = (Point *) r;
+#define Digit_val(nat,pos) (((bng) Data_custom_val(nat))[pos])
 
-  LocalToGlobal (&p[0]);
-  LocalToGlobal (&p[1]);
-}
diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml
new file mode 100644
index 00000000..fcbe5a98
--- /dev/null
+++ b/otherlibs/num/nat.ml
@@ -0,0 +1,570 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: nat.ml,v 1.14 2003/11/21 15:59:38 xleroy Exp $ *)
+
+open Int_misc
+
+type nat;;
+
+external create_nat: int -> nat = "create_nat"
+external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat"
+external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat"
+external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat"
+external nth_digit_nat: nat -> int -> int = "nth_digit_nat"
+external num_digits_nat: nat -> int -> int -> int = "num_digits_nat"
+external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit"
+external is_digit_int: nat -> int -> bool = "is_digit_int"
+external is_digit_zero: nat -> int -> bool = "is_digit_zero"
+external is_digit_normalized: nat -> int -> bool = "is_digit_normalized"
+external is_digit_odd: nat -> int -> bool = "is_digit_odd"
+external incr_nat: nat -> int -> int -> int -> int = "incr_nat"
+external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "add_nat" "add_nat_native"
+external complement_nat: nat -> int -> int -> unit = "complement_nat"
+external decr_nat: nat -> int -> int -> int -> int = "decr_nat"
+external sub_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "sub_nat" "sub_nat_native"
+external mult_digit_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int = "mult_digit_nat" "mult_digit_nat_native"
+external mult_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int -> int = "mult_nat" "mult_nat_native"
+external square_nat: nat -> int -> int -> nat -> int -> int -> int = "square_nat" "square_nat_native"
+external shift_left_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_left_nat" "shift_left_nat_native"
+external div_digit_nat: nat -> int -> nat -> int -> nat -> int -> int -> nat -> int -> unit = "div_digit_nat" "div_digit_nat_native"
+external div_nat: nat -> int -> int -> nat -> int -> int -> unit = "div_nat" "div_nat_native"
+external shift_right_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_right_nat" "shift_right_nat_native"
+external compare_digits_nat: nat -> int -> nat -> int -> int = "compare_digits_nat"
+external compare_nat: nat -> int -> int -> nat -> int -> int -> int = "compare_nat" "compare_nat_native"
+external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat"
+external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat"
+external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat"
+
+external initialize_nat: unit -> unit = "initialize_nat"
+let _ = initialize_nat()
+
+let length_nat (n : nat) = Obj.size (Obj.repr n) - 1
+
+let length_of_digit = Sys.word_size;;
+
+let make_nat len =
+  if len < 0 then invalid_arg "make_nat" else
+    let res = create_nat len in set_to_zero_nat res 0 len; res
+
+(* Nat temporaries *)
+let a_2 = make_nat 2
+and a_1 = make_nat 1 
+and b_2 = make_nat 2 
+
+let copy_nat nat off_set length =
+ let res = create_nat (length) in
+  blit_nat res 0 nat off_set length; 
+  res
+
+let is_zero_nat n off len =
+  compare_nat (make_nat 1) 0 1 n off (num_digits_nat n off len) = 0 
+
+let is_nat_int nat off len =
+  num_digits_nat nat off len = 1 && is_digit_int nat off
+
+let sys_int_of_nat nat off len =
+  if is_nat_int nat off len
+  then nth_digit_nat nat off
+  else failwith "int_of_nat"
+
+let int_of_nat nat =
+  sys_int_of_nat nat 0 (length_nat nat)
+
+let nat_of_int i =
+  if i < 0 then invalid_arg "nat_of_int" else
+    let res = make_nat 1 in
+    if i = 0 then res else begin set_digit_nat res 0 i; res end
+
+let eq_nat nat1 off1 len1 nat2 off2 len2 =
+  compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
+              nat2 off2 (num_digits_nat nat2 off2 len2) = 0
+and le_nat nat1 off1 len1 nat2 off2 len2 =
+  compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
+              nat2 off2 (num_digits_nat nat2 off2 len2) <= 0
+and lt_nat nat1 off1 len1 nat2 off2 len2 =
+  compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
+              nat2 off2 (num_digits_nat nat2 off2 len2) < 0
+and ge_nat nat1 off1 len1 nat2 off2 len2 =
+  compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
+              nat2 off2 (num_digits_nat nat2 off2 len2) >= 0
+and gt_nat nat1 off1 len1 nat2 off2 len2 =
+  compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
+              nat2 off2 (num_digits_nat nat2 off2 len2) > 0
+
+(* XL: now implemented in C for better performance.
+   The code below doesn't handle carries correctly.
+   Fortunately, the carry is never used. *)
+(***
+let square_nat nat1 off1 len1 nat2 off2 len2 =
+  let c = ref 0 
+  and trash = make_nat 1 in
+    (* Double product *)
+    for i = 0 to len2 - 2 do
+        c := !c + mult_digit_nat 
+                         nat1
+                         (succ (off1 + 2 * i))
+                         (2 * (pred (len2 - i)))
+                         nat2 
+                         (succ (off2 + i))
+                         (pred (len2 - i))
+                         nat2
+                         (off2 + i)
+    done;
+    shift_left_nat nat1 0 len1 trash 0 1;
+    (* Square of digit *)
+    for i = 0 to len2 - 1 do
+        c := !c + mult_digit_nat 
+                         nat1 
+                         (off1 + 2 * i)
+                         (len1 - 2 * i)
+                         nat2
+                         (off2 + i)
+                         1
+                         nat2
+                         (off2 + i)
+    done;
+  !c
+***)
+
+let gcd_int_nat i nat off len = 
+  if i = 0 then 1 else
+  if is_nat_int nat off len then begin
+    set_digit_nat nat off (gcd_int (nth_digit_nat nat off) i); 0
+  end else begin
+    let len_copy = succ len in
+    let copy = create_nat len_copy 
+    and quotient = create_nat 1 
+    and remainder = create_nat 1 in
+    blit_nat copy 0 nat off len;
+    set_digit_nat copy len 0;
+    div_digit_nat quotient 0 remainder 0 copy 0 len_copy (nat_of_int i) 0;
+    set_digit_nat nat off (gcd_int (nth_digit_nat remainder 0) i);
+    0
+  end
+
+let exchange r1 r2 =
+  let old1 = !r1 in r1 := !r2; r2 := old1
+
+let gcd_nat nat1 off1 len1 nat2 off2 len2 =
+  if is_zero_nat nat1 off1 len1 then begin
+    blit_nat nat1 off1 nat2 off2 len2; len2
+  end else begin
+    let copy1 = ref (create_nat (succ len1))
+    and copy2 = ref (create_nat (succ len2)) in
+      blit_nat !copy1 0 nat1 off1 len1;
+      blit_nat !copy2 0 nat2 off2 len2;
+      set_digit_nat !copy1 len1 0;
+      set_digit_nat !copy2 len2 0;
+      if lt_nat !copy1 0 len1 !copy2 0 len2
+         then exchange copy1 copy2;
+      let real_len1 = 
+            ref (num_digits_nat !copy1 0 (length_nat !copy1))
+      and real_len2 = 
+            ref (num_digits_nat !copy2 0 (length_nat !copy2)) in
+      while not (is_zero_nat !copy2 0 !real_len2) do
+        set_digit_nat !copy1 !real_len1 0;
+        div_nat !copy1 0 (succ !real_len1) !copy2 0 !real_len2;
+        exchange copy1 copy2;
+        real_len1 := !real_len2;
+        real_len2 := num_digits_nat !copy2 0 !real_len2
+      done;                
+      blit_nat nat1 off1 !copy1 0 !real_len1;
+      !real_len1
+  end
+
+(* Racine carrée entière par la méthode de Newton (entière par défaut). *)
+
+(* Théorème: la suite xn+1 = (xn + a/xn) / 2 converge vers la racine *)
+(* carrée entière de a par défaut, si on part d'une valeur x0 *)
+(* strictement plus grande que la racine de a, sauf quand a est un *)
+(* carré - 1, cas auquel la suite alterne entre la racine par défaut *)
+(* et par excès. Dans tous les cas, le dernier terme de la partie *)
+(* strictement décroissante de la suite est le résultat cherché. *)
+
+let sqrt_nat rad off len =
+ let len = num_digits_nat rad off len in
+ (* Copie de travail du radicande *)
+ let len_parity = len mod 2 in
+ let rad_len = len + 1 + len_parity in
+ let rad =
+   let res = create_nat rad_len in
+   blit_nat res 0 rad off len;
+   set_digit_nat res len 0;
+   set_digit_nat res (rad_len - 1) 0;
+   res in
+ let cand_len = (len + 1) / 2 in  (* ceiling len / 2 *) 
+ let cand_rest = rad_len - cand_len in
+ (* Racine carrée supposée cand = "|FFFF .... |" *)
+ let cand = make_nat cand_len in
+ (* Amélioration de la racine de départ:
+    on calcule nbb le nombre de bits significatifs du premier digit du candidat
+    (la moitié du nombre de bits significatifs dans les deux premiers
+     digits du radicande étendu à une longueur paire).
+    shift_cand est word_size - nbb *)
+ let shift_cand =
+   ((num_leading_zero_bits_in_digit rad (len-1)) +
+     Sys.word_size * len_parity) / 2 in
+ (* Tous les bits du radicande sont à 0, on rend 0. *)
+ if shift_cand = Sys.word_size then cand else
+ begin
+  complement_nat cand 0 cand_len;
+  shift_right_nat cand 0 1 a_1 0 shift_cand;
+  let next_cand = create_nat rad_len in
+  (* Repeat until *)
+  let rec loop () =
+           (* next_cand := rad *)
+   blit_nat next_cand 0 rad 0 rad_len;
+           (* next_cand <- next_cand / cand *)
+   div_nat next_cand 0 rad_len cand 0 cand_len;
+           (* next_cand (poids fort) <- next_cand (poids fort) + cand,
+              i.e. next_cand <- cand + rad / cand *)
+   add_nat next_cand cand_len cand_rest cand 0 cand_len 0;
+        (* next_cand <- next_cand / 2 *)
+   shift_right_nat next_cand cand_len cand_rest a_1 0 1;
+   if lt_nat next_cand cand_len cand_rest cand 0 cand_len then
+    begin  (* cand <- next_cand *)
+     blit_nat cand 0 next_cand cand_len cand_len; loop ()
+    end
+   else cand in
+  loop ()
+ end;;
+
+let power_base_max = make_nat 2;;
+
+match length_of_digit with
+  | 64 -> 
+      set_digit_nat power_base_max 0 (Int64.to_int 1000000000000000000L);
+      mult_digit_nat power_base_max 0 2 
+                     power_base_max 0 1 (nat_of_int 9) 0;
+      ()
+  | 32 -> set_digit_nat power_base_max 0 1000000000
+  | _ -> assert false
+;;
+
+let pmax =
+  match length_of_digit with
+  | 64 -> 19
+  | 32 -> 9
+  | _ -> assert false
+;;
+
+let max_superscript_10_power_in_int =
+  match length_of_digit with
+  | 64 -> 18
+  | 32 -> 9
+  | _ -> assert false
+;;
+let max_power_10_power_in_int =
+  match length_of_digit with
+  | 64 -> nat_of_int (Int64.to_int 1000000000000000000L)
+  | 32 -> nat_of_int 1000000000
+  | _ -> assert false
+;;
+
+let raw_string_of_digit nat off =
+  if is_nat_int nat off 1 
+     then begin string_of_int (nth_digit_nat nat off) end 
+  else begin
+       blit_nat b_2 0 nat off 1;
+       div_digit_nat a_2 0 a_1 0 b_2 0 2 max_power_10_power_in_int 0;
+       let leading_digits = nth_digit_nat a_2 0
+       and s1 = string_of_int (nth_digit_nat a_1 0) in
+       let len = String.length s1 in
+       if leading_digits < 10 then begin
+            let result = String.make (max_superscript_10_power_in_int+1) '0' in
+            String.set result 0 
+                         (Char.chr (48 + leading_digits));
+            String.blit s1 0 
+                 result (String.length result - len) len;
+            result
+       end else begin
+            let result = String.make (max_superscript_10_power_in_int+2) '0' in
+            String.blit (string_of_int leading_digits) 0 result 0 2;
+            String.blit s1 0 
+                 result (String.length result - len) len;
+            result
+       end
+  end
+
+(* XL: suppression de string_of_digit et de sys_string_of_digit.
+   La copie est de toute facon faite dans string_of_nat, qui est le
+   seul point d entree public dans ce code. *)
+
+(******
+let sys_string_of_digit nat off =
+    let s = raw_string_of_digit nat off in
+    let result = String.create (String.length s) in
+    String.blit s 0 result 0 (String.length s);
+    s
+
+let string_of_digit nat =
+    sys_string_of_digit nat 0
+
+*******)
+
+let digits = "0123456789ABCDEF"
+
+(*
+   make_power_base affecte power_base des puissances successives de base a 
+   partir de la puissance 1-ieme.
+   A la fin de la boucle i-1 est la plus grande puissance de la base qui tient 
+   sur un seul digit et j est la plus grande puissance de la base qui tient 
+   sur un int.
+*)
+let make_power_base base power_base = 
+  let i = ref 0 
+  and j = ref 0 in
+   set_digit_nat power_base 0 base;
+   while incr i; is_digit_zero power_base !i do
+   mult_digit_nat power_base !i 2 
+                  power_base (pred !i) 1 
+                  power_base 0
+   done;
+   while !j <= !i && is_digit_int power_base !j do incr j done;
+  (!i - 2, !j)
+
+(* 
+   int_to_string place la representation de l entier int en base base 
+   dans la chaine s en le rangeant de la fin indiquee par pos vers le 
+   debut, sur times places et affecte a pos sa nouvelle valeur. 
+*)
+let int_to_string int s pos_ref base times = 
+  let i = ref int 
+  and j = ref times in
+     while ((!i != 0) || (!j != 0)) && (!pos_ref != -1) do
+        String.set s !pos_ref (String.get digits (!i mod base));
+        decr pos_ref;
+        decr j;
+        i := !i / base
+     done
+
+(* XL: suppression de adjust_string *)
+
+let power_base_int base i = 
+  if i = 0 then
+    nat_of_int 1 
+  else if i < 0 then
+    invalid_arg "power_base_int"
+  else begin
+         let power_base = make_nat (succ length_of_digit) in
+         let (pmax, pint) = make_power_base base power_base in
+         let n = i / (succ pmax) 
+         and rem = i mod (succ pmax) in
+           if n > 0 then begin
+               let newn =
+                 if i = biggest_int then n else (succ n) in
+               let res = make_nat newn
+               and res2 = make_nat newn
+               and l = num_bits_int n - 2 in
+               let p = ref (1 lsl l) in
+                 blit_nat res 0 power_base pmax 1;
+                 for i = l downto 0 do
+                   let len = num_digits_nat res 0 newn in
+                   let len2 = min n (2 * len) in
+                   let succ_len2 = succ len2 in
+                     square_nat res2 0 len2 res 0 len;
+                     if n land !p > 0 then begin
+                       set_to_zero_nat res 0 len;
+                       mult_digit_nat res 0 succ_len2 
+                                      res2 0 len2 
+                                      power_base pmax;
+                       ()
+                     end else
+                       blit_nat res 0 res2 0 len2;
+                     set_to_zero_nat res2 0 len2;
+                     p := !p lsr 1
+                 done;
+               if rem > 0 then begin
+                 mult_digit_nat res2 0 newn 
+                                res 0 n power_base (pred rem);
+                 res2
+               end else res
+            end else 
+              copy_nat power_base (pred rem) 1
+  end
+
+(* the ith element (i >= 2) of num_digits_max_vector is :
+    |                                 |
+    | biggest_string_length * log (i) |
+    | ------------------------------- | + 1
+    |      length_of_digit * log (2)  |
+    --                               --
+*)
+
+(* XL: ai specialise le code d origine a length_of_digit = 32. *)
+(* Puis suppression (inutile?) *)
+
+(******
+let num_digits_max_vector = 
+  [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402; 
+              3543; 3671; 3789; 3899; 4001; 4096|]
+
+let num_digits_max_vector = 
+   match length_of_digit with
+     16 -> [|0; 0; 2048; 3246; 4096; 4755; 5294; 5749; 6144; 6492; 6803; 
+              7085; 7342; 7578; 7797; 8001; 8192|]
+(* If really exotic machines !!!!
+   | 17 -> [|0; 0; 1928; 3055; 3855; 4476; 4983; 5411; 5783; 6110; 6403; 
+              6668; 6910; 7133; 7339; 7530; 7710|]
+   | 18 -> [|0; 0; 1821; 2886; 3641; 4227; 4706; 5111; 5461; 5771; 6047; 
+              6298; 6526; 6736; 6931; 7112; 7282|]
+   | 19 -> [|0; 0; 1725; 2734; 3449; 4005; 4458; 4842; 5174; 5467; 5729; 
+              5966; 6183; 6382; 6566; 6738; 6898|]
+   | 20 -> [|0; 0; 1639; 2597; 3277; 3804; 4235; 4600; 4915; 5194; 5443; 
+              5668; 5874; 6063; 6238; 6401; 6553|] 
+   | 21 -> [|0; 0; 1561; 2473; 3121; 3623; 4034; 4381; 4681; 4946; 5183; 
+              5398; 5594; 5774; 5941; 6096; 6241|]
+   | 22 -> [|0; 0; 1490; 2361; 2979; 3459; 3850; 4182; 4468; 4722; 4948; 
+              5153; 5340; 5512; 5671; 5819; 5958|]
+   | 23 -> [|0; 0; 1425; 2258; 2850; 3308; 3683; 4000; 4274; 4516; 4733; 
+              4929; 5108; 5272; 5424; 5566; 5699|]
+   | 24 -> [|0; 0; 1366; 2164; 2731; 3170; 3530; 3833; 4096; 4328; 4536; 
+              4723; 4895; 5052; 5198; 5334; 5461|]
+   | 25 -> [|0; 0; 1311; 2078; 2622; 3044; 3388; 3680; 3932; 4155; 4354; 
+              4534; 4699; 4850; 4990; 5121; 5243|]
+   | 26 -> [|0; 0; 1261; 1998; 2521; 2927; 3258; 3538; 3781; 3995; 4187; 
+              4360; 4518; 4664; 4798; 4924; 5041|]
+   | 27 -> [|0; 0; 1214; 1924; 2428; 2818; 3137; 3407; 3641; 3847; 4032; 
+              4199; 4351; 4491; 4621; 4742; 4855|]
+   | 28 -> [|0; 0; 1171; 1855; 2341; 2718; 3025; 3286; 3511; 3710; 3888; 
+              4049; 4196; 4331; 4456; 4572; 4681|]
+   | 29 -> [|0; 0; 1130; 1791; 2260; 2624; 2921; 3172; 3390; 3582; 3754; 
+              3909; 4051; 4181; 4302; 4415; 4520|]
+   | 30 -> [|0; 0; 1093; 1732; 2185; 2536; 2824; 3067; 3277; 3463; 3629; 
+              3779; 3916; 4042; 4159; 4267; 4369|]
+   | 31 -> [|0; 0; 1057; 1676; 2114; 2455; 2733; 2968; 3171; 3351; 3512; 
+              3657; 3790; 3912; 4025; 4130; 4228|]
+*)
+   | 32 -> [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402; 
+              3543; 3671; 3789; 3899; 4001; 4096|]
+   | n -> failwith "num_digits_max_vector"
+******)
+
+(* XL: suppression de string_list_of_nat *)
+
+let unadjusted_string_of_nat nat off len_nat =
+  let len = num_digits_nat nat off len_nat in
+  if len = 1 then
+       raw_string_of_digit nat off
+  else
+       let len_copy = ref (succ len) in
+       let copy1 = create_nat !len_copy
+       and copy2 = make_nat !len_copy
+       and rest_digit = make_nat 2 in
+         if len > biggest_int / (succ pmax)
+            then failwith "number too long" 
+            else let len_s = (succ pmax) * len in
+                 let s = String.make len_s '0'
+                 and pos_ref = ref len_s in
+                   len_copy := pred !len_copy; 
+                   blit_nat copy1 0 nat off len;
+                   set_digit_nat copy1 len 0;
+                   while not (is_zero_nat copy1 0 !len_copy) do  
+                      div_digit_nat copy2 0 
+                                     rest_digit 0 
+                                     copy1 0 (succ !len_copy) 
+                                     power_base_max 0;
+                      let str = raw_string_of_digit rest_digit 0 in
+                      String.blit str 0 
+                                  s (!pos_ref - String.length str)
+                                  (String.length str);
+                      (* XL: il y avait pmax a la place de String.length str
+                         mais ca ne marche pas avec le blit de Caml Light,
+                         qui ne verifie pas les debordements *)
+                      pos_ref := !pos_ref - pmax;
+                      len_copy := num_digits_nat copy2 0 !len_copy; 
+                      blit_nat copy1 0 copy2 0 !len_copy;
+                      set_digit_nat copy1 !len_copy 0 
+                   done;
+                   s
+
+let string_of_nat nat = 
+  let s = unadjusted_string_of_nat nat 0 (length_nat nat) 
+  and index = ref 0 in
+    begin try
+      for i = 0 to String.length s - 2 do
+       if String.get s i <> '0' then (index:= i; raise Exit)
+      done
+    with Exit -> ()
+    end;
+    String.sub s !index (String.length s - !index)
+
+(* XL: suppression de sys_string_of_nat *)
+
+(* XL: suppression de debug_string_nat *)
+
+let base_digit_of_char c base =
+  let n = Char.code c in
+    if n >= 48 && n <= 47 + min base 10 then n - 48
+    else if n >= 65 && n <= 65 + base - 11 then n - 55
+    else failwith "invalid digit"
+
+(* 
+   La sous-chaine (s, off, len) represente un nat en base base que 
+   on determine ici 
+*)
+let sys_nat_of_string base s off len = 
+  let power_base = make_nat (succ length_of_digit) in
+  let (pmax, pint) = make_power_base base power_base in
+  let new_len = ref (1 + len / (pmax + 1))
+  and current_len = ref 1 in
+  let possible_len = ref (min 2 !new_len) in
+
+  let nat1 = make_nat !new_len
+  and nat2 = make_nat !new_len 
+
+  and digits_read = ref 0 
+  and bound = off + len - 1
+  and int = ref 0 in
+
+  for i = off to bound do
+    (* 
+       on lit pint (au maximum) chiffres, on en fait un int 
+       et on l integre au nombre
+     *)
+      let c = String.get s i  in
+        begin match c with 
+          ' ' | '\t' | '\n' | '\r' | '\\' -> ()
+        | _ -> int := !int * base + base_digit_of_char c base;
+               incr digits_read
+        end;
+        if (!digits_read = pint || i = bound) && not (!digits_read = 0) then 
+          begin
+           set_digit_nat nat1 0 !int;
+           let erase_len = if !new_len = !current_len then !current_len - 1
+                           else !current_len in
+           for j = 1 to erase_len do 
+             set_digit_nat nat1 j 0
+           done;
+           mult_digit_nat nat1 0 !possible_len 
+                          nat2 0 !current_len 
+                          power_base (pred !digits_read);
+           blit_nat nat2 0 nat1 0 !possible_len;
+           current_len := num_digits_nat nat1 0 !possible_len;
+           possible_len := min !new_len (succ !current_len);
+           int := 0;
+           digits_read := 0
+           end
+  done;
+  (* 
+     On recadre le nat 
+  *)
+  let nat = create_nat !current_len in
+    blit_nat nat 0 nat1 0 !current_len;
+    nat
+
+let nat_of_string s = sys_nat_of_string 10 s 0 (String.length s)
+
+let float_of_nat nat = float_of_string(string_of_nat nat)
+
diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli
new file mode 100644
index 00000000..b3cb6da2
--- /dev/null
+++ b/otherlibs/num/nat.mli
@@ -0,0 +1,71 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: nat.mli,v 1.11 2003/11/07 07:59:09 xleroy Exp $ *)
+
+(* Module [Nat]: operations on natural numbers *)
+
+type nat
+
+(* Natural numbers (type [nat]) are positive integers of arbitrary size.
+   All operations on [nat] are performed in-place. *)
+
+external create_nat: int -> nat = "create_nat"
+val make_nat: int -> nat
+external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat"
+external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat"
+val copy_nat: nat -> int -> int -> nat
+external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat"
+external nth_digit_nat: nat -> int -> int = "nth_digit_nat"
+val length_nat : nat -> int 
+external num_digits_nat: nat -> int -> int -> int = "num_digits_nat"
+external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit"
+external is_digit_int: nat -> int -> bool = "is_digit_int"
+external is_digit_zero: nat -> int -> bool = "is_digit_zero"
+external is_digit_normalized: nat -> int -> bool = "is_digit_normalized"
+external is_digit_odd: nat -> int -> bool = "is_digit_odd"
+val is_zero_nat: nat -> int -> int -> bool
+val is_nat_int: nat -> int -> int -> bool
+val int_of_nat: nat -> int
+val nat_of_int: int -> nat
+external incr_nat: nat -> int -> int -> int -> int = "incr_nat"
+external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "add_nat" "add_nat_native"
+external complement_nat: nat -> int -> int -> unit = "complement_nat"
+external decr_nat: nat -> int -> int -> int -> int = "decr_nat"
+external sub_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "sub_nat" "sub_nat_native"
+external mult_digit_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int = "mult_digit_nat" "mult_digit_nat_native"
+external mult_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int -> int = "mult_nat" "mult_nat_native"
+external square_nat: nat -> int -> int -> nat -> int -> int -> int = "square_nat" "square_nat_native"
+external shift_left_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_left_nat" "shift_left_nat_native"
+external div_digit_nat: nat -> int -> nat -> int -> nat -> int -> int -> nat -> int -> unit = "div_digit_nat" "div_digit_nat_native"
+external div_nat: nat -> int -> int -> nat -> int -> int -> unit = "div_nat" "div_nat_native"
+external shift_right_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_right_nat" "shift_right_nat_native"
+external compare_digits_nat: nat -> int -> nat -> int -> int = "compare_digits_nat"
+external compare_nat: nat -> int -> int -> nat -> int -> int -> int = "compare_nat" "compare_nat_native"
+val eq_nat : nat -> int -> int -> nat -> int -> int -> bool
+val le_nat : nat -> int -> int -> nat -> int -> int -> bool
+val lt_nat : nat -> int -> int -> nat -> int -> int -> bool
+val ge_nat : nat -> int -> int -> nat -> int -> int -> bool
+val gt_nat : nat -> int -> int -> nat -> int -> int -> bool
+external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat"
+external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat"
+external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat"
+val gcd_nat : nat -> int -> int -> nat -> int -> int -> int
+val sqrt_nat : nat -> int -> int -> nat
+val string_of_nat : nat -> string
+val nat_of_string : string -> nat
+val sys_nat_of_string : int -> string -> int -> int -> nat
+val float_of_nat : nat -> float
+val make_power_base :  int -> nat -> int * int
+val power_base_int : int -> int -> nat
+val length_of_digit: int
diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c
new file mode 100644
index 00000000..c4eab961
--- /dev/null
+++ b/otherlibs/num/nat_stubs.c
@@ -0,0 +1,369 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: nat_stubs.c,v 1.14 2003/11/07 07:59:09 xleroy Exp $ */
+
+#include "alloc.h"
+#include "custom.h"
+#include "intext.h"
+#include "fail.h"
+#include "memory.h"
+#include "mlvalues.h"
+
+#include "bng.h"
+#include "nat.h"
+
+/* Stub code for the Nat module. */
+
+static void serialize_nat(value, unsigned long *, unsigned long *);
+static unsigned long deserialize_nat(void * dst);
+
+static struct custom_operations nat_operations = {
+  "_nat",
+  custom_finalize_default,
+  custom_compare_default,
+  custom_hash_default,
+  serialize_nat,
+  deserialize_nat
+};
+
+CAMLprim value initialize_nat(value unit)
+{
+  bng_init();
+  register_custom_operations(&nat_operations);
+  return Val_unit;
+}
+
+CAMLprim value create_nat(value size)
+{
+  mlsize_t sz = Long_val(size);
+
+  return alloc_custom(&nat_operations, sz * sizeof(value), 0, 1);
+}
+
+CAMLprim value length_nat(value nat)
+{
+  return Val_long(Wosize_val(nat) - 1);
+}
+
+CAMLprim value set_to_zero_nat(value nat, value ofs, value len)
+{
+  bng_zero(&Digit_val(nat, Long_val(ofs)), Long_val(len));
+  return Val_unit;
+}
+
+CAMLprim value blit_nat(value nat1, value ofs1,
+                        value nat2, value ofs2,
+                        value len)
+{
+  bng_assign(&Digit_val(nat1, Long_val(ofs1)),
+             &Digit_val(nat2, Long_val(ofs2)),
+             Long_val(len));
+  return Val_unit;
+}
+
+CAMLprim value set_digit_nat(value nat, value ofs, value digit)
+{
+  Digit_val(nat, Long_val(ofs)) = Long_val(digit);
+  return Val_unit;
+}
+
+CAMLprim value nth_digit_nat(value nat, value ofs)
+{
+  return Val_long(Digit_val(nat, Long_val(ofs)));
+}
+
+CAMLprim value num_digits_nat(value nat, value ofs, value len)
+{
+  return Val_long(bng_num_digits(&Digit_val(nat, Long_val(ofs)),
+                                 Long_val(len)));
+}
+
+CAMLprim value num_leading_zero_bits_in_digit(value nat, value ofs)
+{
+  return
+    Val_long(bng_leading_zero_bits(Digit_val(nat, Long_val(ofs))));
+}
+
+CAMLprim value is_digit_int(value nat, value ofs)
+{
+  return Val_bool(Digit_val(nat, Long_val(ofs)) <= Max_long);
+}
+
+CAMLprim value is_digit_zero(value nat, value ofs)
+{
+  return Val_bool(Digit_val(nat, Long_val(ofs)) == 0);
+}
+
+CAMLprim value is_digit_normalized(value nat, value ofs)
+{
+  return
+    Val_bool(Digit_val(nat, Long_val(ofs)) & (1L << (BNG_BITS_PER_DIGIT-1)));
+}
+
+CAMLprim value is_digit_odd(value nat, value ofs)
+{
+  return Val_bool(Digit_val(nat, Long_val(ofs)) & 1);
+}
+
+CAMLprim value incr_nat(value nat, value ofs, value len, value carry_in)
+{
+  return Val_long(bng_add_carry(&Digit_val(nat, Long_val(ofs)),
+                                Long_val(len), Long_val(carry_in)));
+}
+
+value add_nat_native(value nat1, value ofs1, value len1,
+                     value nat2, value ofs2, value len2, value carry_in)
+{
+  return Val_long(bng_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
+                          &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
+                          Long_val(carry_in)));
+}
+
+CAMLprim value add_nat(value *argv, int argn)
+{
+  return add_nat_native(argv[0], argv[1], argv[2], argv[3],
+                        argv[4], argv[5], argv[6]);
+}
+
+CAMLprim value complement_nat(value nat, value ofs, value len)
+{
+  bng_complement(&Digit_val(nat, Long_val(ofs)), Long_val(len));
+  return Val_unit;
+}
+
+CAMLprim value decr_nat(value nat, value ofs, value len, value carry_in)
+{
+  return Val_long(1 ^ bng_sub_carry(&Digit_val(nat, Long_val(ofs)),
+                                    Long_val(len), 1 ^ Long_val(carry_in)));
+}
+
+value sub_nat_native(value nat1, value ofs1, value len1,
+                     value nat2, value ofs2, value len2, value carry_in)
+{
+  return Val_long(1 ^ bng_sub(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
+                              &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
+                              1 ^ Long_val(carry_in)));
+}
+
+CAMLprim value sub_nat(value *argv, int argn)
+{
+  return sub_nat_native(argv[0], argv[1], argv[2], argv[3],
+                        argv[4], argv[5], argv[6]);
+}
+
+value mult_digit_nat_native(value nat1, value ofs1, value len1,
+                            value nat2, value ofs2, value len2,
+                            value nat3, value ofs3)
+{
+  return
+    Val_long(bng_mult_add_digit(
+                   &Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
+                   &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
+                   Digit_val(nat3, Long_val(ofs3))));
+}
+
+CAMLprim value mult_digit_nat(value *argv, int argn)
+{
+  return mult_digit_nat_native(argv[0], argv[1], argv[2], argv[3],
+                               argv[4], argv[5], argv[6], argv[7]);
+}
+
+value mult_nat_native(value nat1, value ofs1, value len1,
+                      value nat2, value ofs2, value len2,
+                      value nat3, value ofs3, value len3)
+{
+  return
+    Val_long(bng_mult_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
+                          &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
+                          &Digit_val(nat3, Long_val(ofs3)), Long_val(len3)));
+}
+
+CAMLprim value mult_nat(value *argv, int argn)
+{
+  return mult_nat_native(argv[0], argv[1], argv[2], argv[3],
+                         argv[4], argv[5], argv[6], argv[7], argv[8]);
+}
+
+value square_nat_native(value nat1, value ofs1, value len1,
+                        value nat2, value ofs2, value len2)
+{
+  return
+    Val_long(bng_square_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
+                            &Digit_val(nat2, Long_val(ofs2)), Long_val(len2)));
+}
+
+CAMLprim value square_nat(value *argv, int argn)
+{
+  return square_nat_native(argv[0], argv[1], argv[2],
+                           argv[3], argv[4], argv[5]);
+}
+
+value shift_left_nat_native(value nat1, value ofs1, value len1,
+                            value nat2, value ofs2, value nbits)
+{
+  Digit_val(nat2, Long_val(ofs2)) =
+    bng_shift_left(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
+                   Long_val(nbits));
+  return Val_unit;
+}
+
+CAMLprim value shift_left_nat(value *argv, int argn)
+{
+  return shift_left_nat_native(argv[0], argv[1], argv[2],
+                               argv[3], argv[4], argv[5]);
+}
+
+value div_digit_nat_native(value natq, value ofsq,
+                           value natr, value ofsr,
+                           value nat1, value ofs1, value len1,
+                           value nat2, value ofs2)
+{
+  Digit_val(natr, Long_val(ofsr)) =
+    bng_div_rem_digit(&Digit_val(natq, Long_val(ofsq)),
+                      &Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
+                      Digit_val(nat2, Long_val(ofs2)));
+  return Val_unit;
+}
+
+CAMLprim value div_digit_nat(value *argv, int argn)
+{
+  return div_digit_nat_native(argv[0], argv[1], argv[2], argv[3],
+                              argv[4], argv[5], argv[6], argv[7], argv[8]);
+}
+
+value div_nat_native(value nat1, value ofs1, value len1,
+                     value nat2, value ofs2, value len2)
+{
+  bng_div_rem(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
+              &Digit_val(nat2, Long_val(ofs2)), Long_val(len2));
+  return Val_unit;
+}
+
+CAMLprim value div_nat(value *argv, int argn)
+{
+  return div_nat_native(argv[0], argv[1], argv[2],
+                        argv[3], argv[4], argv[5]);
+}
+ 
+value shift_right_nat_native(value nat1, value ofs1, value len1,
+                             value nat2, value ofs2, value nbits)
+{
+  Digit_val(nat2, Long_val(ofs2)) =
+    bng_shift_right(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
+                    Long_val(nbits));
+  return Val_unit;
+}
+
+CAMLprim value shift_right_nat(value *argv, int argn)
+{
+  return shift_right_nat_native(argv[0], argv[1], argv[2],
+                                argv[3], argv[4], argv[5]);
+}
+
+CAMLprim value compare_digits_nat(value nat1, value ofs1, 
+                                  value nat2, value ofs2)
+{
+  bngdigit d1 = Digit_val(nat1, Long_val(ofs1));
+  bngdigit d2 = Digit_val(nat2, Long_val(ofs2));
+  if (d1 > d2) return Val_int(1);
+  if (d1 < d2) return Val_int(-1);
+  return Val_int(0);
+}
+
+value compare_nat_native(value nat1, value ofs1, value len1,
+                         value nat2, value ofs2, value len2)
+{
+  return
+    Val_int(bng_compare(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
+                        &Digit_val(nat2, Long_val(ofs2)), Long_val(len2)));
+}
+
+CAMLprim value compare_nat(value *argv, int argn)
+{
+  return compare_nat_native(argv[0], argv[1], argv[2],
+                            argv[3], argv[4], argv[5]);
+}
+
+CAMLprim value land_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
+{
+  Digit_val(nat1, Long_val(ofs1)) &= Digit_val(nat2, Long_val(ofs2));
+  return Val_unit;
+}
+
+CAMLprim value lor_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
+{
+  Digit_val(nat1, Long_val(ofs1)) |= Digit_val(nat2, Long_val(ofs2));
+  return Val_unit;
+}
+
+CAMLprim value lxor_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
+{
+  Digit_val(nat1, Long_val(ofs1)) ^= Digit_val(nat2, Long_val(ofs2));
+  return Val_unit;
+}
+
+/* The wire format for a nat is:
+   - 32-bit word: number of 32-bit words in nat
+   - N 32-bit words (big-endian format)
+   For little-endian platforms, the memory layout between 32-bit and 64-bit
+   machines is identical, so we can write the nat using serialize_block_4.
+   For big-endian 64-bit platforms, we need to swap the two 32-bit halves
+   of 64-bit words to obtain the correct behavior. */
+
+static void serialize_nat(value nat, 
+                          unsigned long * wsize_32,
+                          unsigned long * wsize_64)
+{
+  mlsize_t len = Wosize_val(nat) - 1;
+
+#ifdef ARCH_SIXTYFOUR
+  len = len * 2; /* two 32-bit words per 64-bit digit  */
+  if (len >= (1L << 32))
+    failwith("output_value: nat too big");
+#endif
+  serialize_int_4((int32) len);
+#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
+  { int32 * p;
+    mlsize_t i;
+    for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) {
+      serialize_int_4(p[1]);    /* low 32 bits of 64-bit digit */
+      serialize_int_4(p[0]);    /* high 32 bits of 64-bit digit */
+    }
+  }
+#else
+  serialize_block_4(Data_custom_val(nat), len);
+#endif
+  *wsize_32 = len * 4;
+  *wsize_64 = len * 4;
+}
+
+static unsigned long deserialize_nat(void * dst)
+{
+  mlsize_t len;
+
+  len = deserialize_uint_4();
+#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
+  { uint32 * p;
+    mlsize_t i;
+    for (i = len, p = dst; i > 0; i -= 2, p += 2) {
+      p[1] = deserialize_uint_4();   /* low 32 bits of 64-bit digit */
+      p[0] = deserialize_uint_4();   /* high 32 bits of 64-bit digit */
+    }
+  }
+#else
+  deserialize_block_4(dst, len);
+#endif
+  return len * 4;
+}
+
diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml
new file mode 100644
index 00000000..cdbeb07d
--- /dev/null
+++ b/otherlibs/num/num.ml
@@ -0,0 +1,396 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: num.ml,v 1.6 2001/12/07 13:40:16 xleroy Exp $ *)
+
+open Int_misc
+open Nat
+open Big_int
+open Arith_flags
+open Ratio
+
+type num = Int of int | Big_int of big_int | Ratio of ratio
+        (* The type of numbers. *)
+
+let biggest_INT = big_int_of_int biggest_int
+and least_INT = big_int_of_int least_int
+
+(* Coercion big_int -> num *)
+let num_of_big_int bi = 
+ if le_big_int bi biggest_INT && ge_big_int bi least_INT
+ then Int (int_of_big_int bi)
+ else Big_int bi
+
+let numerator_num = function
+  Ratio r -> normalize_ratio r; num_of_big_int (numerator_ratio r)
+| n -> n
+
+let denominator_num = function
+  Ratio r -> normalize_ratio r; num_of_big_int (denominator_ratio r)
+| n -> Int 1
+
+let normalize_num = function
+  Int i -> Int i
+| Big_int bi -> num_of_big_int bi
+| Ratio r -> if is_integer_ratio r
+              then num_of_big_int (numerator_ratio r)
+              else Ratio r
+
+let cautious_normalize_num_when_printing n =
+ if (!normalize_ratio_when_printing_flag) then (normalize_num n) else n
+
+let num_of_ratio r = 
+ normalize_ratio r; 
+ if not (is_integer_ratio r) then Ratio r
+ else if is_int_big_int (numerator_ratio r) then
+        Int (int_of_big_int (numerator_ratio r))
+ else Big_int (numerator_ratio r)
+
+(* Operations on num *)
+
+let add_num a b = match (a,b) with
+    ((Int int1), (Int int2)) ->
+      let r =  int1 + int2 in
+      if (int1 lxor int2) lor (int1 lxor (r lxor (-1))) < 0
+      then Int r                        (* No overflow *)
+      else Big_int(add_big_int (big_int_of_int int1) (big_int_of_int int2))
+  | ((Int i), (Big_int bi)) ->
+      num_of_big_int (add_int_big_int i bi)
+  | ((Big_int bi), (Int i)) ->
+      num_of_big_int (add_int_big_int i bi)
+
+  | ((Int i), (Ratio r)) ->
+      Ratio (add_int_ratio i r)
+  | ((Ratio r), (Int i)) ->
+      Ratio (add_int_ratio i r)
+
+  | ((Big_int bi1), (Big_int bi2)) -> num_of_big_int (add_big_int bi1 bi2)
+
+  | ((Big_int bi), (Ratio r)) ->
+      Ratio (add_big_int_ratio bi r)
+  | ((Ratio r), (Big_int bi)) ->
+      Ratio (add_big_int_ratio bi r)
+
+  | ((Ratio r1), (Ratio r2)) -> num_of_ratio (add_ratio r1 r2)
+
+let ( +/ ) = add_num
+
+let minus_num = function 
+  Int i -> if i = monster_int
+              then Big_int (minus_big_int (big_int_of_int i))
+              else Int (-i)
+| Big_int bi -> Big_int (minus_big_int bi)
+| Ratio r -> Ratio (minus_ratio r)
+
+let sub_num n1 n2 = add_num n1 (minus_num n2)
+
+let ( -/ ) = sub_num
+
+let mult_num a b = match (a,b) with
+   ((Int int1), (Int int2)) ->
+    if num_bits_int int1 + num_bits_int int2 < length_of_int
+       then Int (int1 * int2)
+       else num_of_big_int (mult_big_int (big_int_of_int int1) 
+                                         (big_int_of_int int2))
+
+ | ((Int i), (Big_int bi)) ->
+     num_of_big_int (mult_int_big_int i bi)
+ | ((Big_int bi), (Int i)) ->
+     num_of_big_int (mult_int_big_int i bi)
+
+ | ((Int i), (Ratio r)) ->
+     num_of_ratio (mult_int_ratio i r)
+ | ((Ratio r), (Int i)) ->
+     num_of_ratio (mult_int_ratio i r)
+
+ | ((Big_int bi1), (Big_int bi2)) -> 
+     num_of_big_int (mult_big_int bi1 bi2)
+
+ | ((Big_int bi), (Ratio r)) ->
+     num_of_ratio (mult_big_int_ratio bi r)
+ | ((Ratio r), (Big_int bi)) ->
+     num_of_ratio (mult_big_int_ratio bi r)
+
+ | ((Ratio r1), (Ratio r2)) ->
+     num_of_ratio (mult_ratio r1 r2)
+
+let ( */ ) = mult_num
+
+let square_num = function
+   Int i -> if 2 * num_bits_int i < length_of_int 
+               then Int (i * i)
+               else num_of_big_int (square_big_int (big_int_of_int i))
+ | Big_int bi -> Big_int (square_big_int bi)
+ | Ratio r -> Ratio (square_ratio r)
+
+let div_num n1 n2 =
+ match n1 with
+ | Int i1 ->
+    begin match n2 with
+    | Int i2 ->
+       num_of_ratio (create_ratio (big_int_of_int i1) (big_int_of_int i2))
+    | Big_int bi2 -> num_of_ratio (create_ratio (big_int_of_int i1) bi2)
+    | Ratio r2 -> num_of_ratio (div_int_ratio i1 r2) end
+
+ | Big_int bi1 ->
+     begin match n2 with
+     | Int i2 -> num_of_ratio (create_ratio bi1 (big_int_of_int i2))
+     | Big_int bi2 -> num_of_ratio (create_ratio bi1 bi2)
+     | Ratio r2 -> num_of_ratio (div_big_int_ratio bi1 r2) end
+
+ | Ratio r1 ->
+     begin match n2 with
+     | Int i2 -> num_of_ratio (div_ratio_int r1 i2)
+     | Big_int bi2 -> num_of_ratio (div_ratio_big_int r1 bi2)
+     | Ratio r2 -> num_of_ratio (div_ratio r1 r2) end
+;;
+
+let ( // ) = div_num
+
+let floor_num = function
+  Int i as n -> n
+| Big_int bi as n -> n
+| Ratio r -> num_of_big_int (floor_ratio r)
+
+let quo_num x y = floor_num (div_num x y)
+
+let mod_num x y = sub_num x (mult_num y (quo_num x y))
+
+let power_num_int a b = match (a,b) with
+   ((Int i), n) ->
+       (match sign_int n with
+           0 -> Int 1
+         | 1 -> num_of_big_int (power_int_positive_int i n)
+         | _ -> Ratio (create_normalized_ratio
+                        unit_big_int (power_int_positive_int i (-n))))
+| ((Big_int bi), n) -> 
+       (match sign_int n with
+           0 -> Int 1
+         | 1 -> num_of_big_int (power_big_int_positive_int bi n)
+         | _ -> Ratio (create_normalized_ratio
+                 unit_big_int (power_big_int_positive_int bi (-n))))
+| ((Ratio r), n) ->
+       (match sign_int n with
+           0 -> Int 1
+         | 1 -> Ratio (power_ratio_positive_int r n)
+         | _ -> Ratio (power_ratio_positive_int 
+                         (inverse_ratio r) (-n)))
+
+let power_num_big_int a b =  match (a,b) with
+   ((Int i), n) -> 
+    (match sign_big_int n with
+           0 -> Int 1
+         | 1 -> num_of_big_int (power_int_positive_big_int i n)
+         | _ -> Ratio (create_normalized_ratio
+                         unit_big_int 
+                         (power_int_positive_big_int i (minus_big_int n))))
+| ((Big_int bi), n) -> 
+       (match sign_big_int n with
+           0 -> Int 1
+         | 1 -> num_of_big_int (power_big_int_positive_big_int bi n)
+         | _ -> Ratio (create_normalized_ratio
+                         unit_big_int 
+                         (power_big_int_positive_big_int bi (minus_big_int n))))
+| ((Ratio r), n) ->
+       (match sign_big_int n with
+           0 -> Int 1
+         | 1 -> Ratio (power_ratio_positive_big_int r n)
+         | _ -> Ratio (power_ratio_positive_big_int 
+                         (inverse_ratio r) (minus_big_int n)))
+
+let power_num a b = match (a,b) with
+  (n, (Int i)) -> power_num_int n i
+| (n, (Big_int bi)) -> power_num_big_int n bi
+| _ -> invalid_arg "power_num"
+
+let ( **/ ) = power_num
+
+let is_integer_num = function
+  Int _     -> true
+| Big_int _ -> true
+| Ratio r   -> is_integer_ratio r
+
+(* integer_num, floor_num, round_num, ceiling_num rendent des nums *)
+let integer_num = function        
+  Int i as n -> n
+| Big_int bi as n -> n
+| Ratio r -> num_of_big_int (integer_ratio r)
+
+and round_num = function
+  Int i as n -> n
+| Big_int bi as n -> n
+| Ratio r -> num_of_big_int (round_ratio r)
+
+and ceiling_num = function
+  Int i as n -> n
+| Big_int bi as n -> n
+| Ratio r -> num_of_big_int (ceiling_ratio r)
+
+(* Comparisons on nums *)
+
+let sign_num = function
+  Int i -> sign_int i
+| Big_int bi -> sign_big_int bi
+| Ratio r -> sign_ratio r
+
+let eq_num a b = match (a,b) with
+  ((Int int1), (Int int2)) -> int1 = int2
+
+| ((Int i), (Big_int bi)) -> eq_big_int (big_int_of_int i) bi
+| ((Big_int bi), (Int i)) -> eq_big_int (big_int_of_int i) bi
+
+| ((Int i), (Ratio r)) -> eq_big_int_ratio (big_int_of_int i) r
+| ((Ratio r), (Int i)) -> eq_big_int_ratio (big_int_of_int i) r
+
+| ((Big_int bi1), (Big_int bi2)) -> eq_big_int bi1 bi2
+
+| ((Big_int bi), (Ratio r)) -> eq_big_int_ratio bi r
+| ((Ratio r), (Big_int bi)) -> eq_big_int_ratio bi r
+
+| ((Ratio r1), (Ratio r2)) -> eq_ratio r1 r2
+
+let ( =/ ) = eq_num
+
+let ( <>/ ) a b = not(eq_num a b)
+
+let compare_num a b = match (a,b) with
+  ((Int int1), (Int int2)) -> compare_int int1 int2
+
+| ((Int i), (Big_int bi)) -> compare_big_int (big_int_of_int i) bi
+| ((Big_int bi), (Int i)) -> compare_big_int bi (big_int_of_int i)
+
+| ((Int i), (Ratio r)) -> compare_big_int_ratio (big_int_of_int i) r
+| ((Ratio r), (Int i)) -> -(compare_big_int_ratio (big_int_of_int i) r)
+
+| ((Big_int bi1), (Big_int bi2)) -> compare_big_int bi1 bi2
+
+| ((Big_int bi), (Ratio r)) -> compare_big_int_ratio bi r
+| ((Ratio r), (Big_int bi)) -> -(compare_big_int_ratio bi r)
+
+| ((Ratio r1), (Ratio r2)) -> compare_ratio r1 r2
+
+let lt_num num1 num2 = compare_num num1 num2 < 0
+and le_num num1 num2 = compare_num num1 num2 <= 0
+and gt_num num1 num2 = compare_num num1 num2 > 0
+and ge_num num1 num2 = compare_num num1 num2 >= 0
+
+let ( </ ) = lt_num
+and ( <=/ ) = le_num
+and ( >/ ) = gt_num
+and ( >=/ ) = ge_num
+
+let max_num num1 num2 = if lt_num num1 num2 then num2 else num1
+and min_num num1 num2 = if gt_num num1 num2 then num2 else num1
+
+(* Coercions with basic types *)
+
+(* Coercion with int type *)
+let int_of_num = function
+  Int i -> i
+| Big_int bi -> int_of_big_int bi
+| Ratio r -> int_of_ratio r
+
+and num_of_int i = 
+  if i = monster_int
+  then Big_int (big_int_of_int i)
+  else Int i
+
+(* Coercion with nat type *)
+let nat_of_num = function
+  Int i -> nat_of_int i
+| Big_int bi -> nat_of_big_int bi
+| Ratio r -> nat_of_ratio r
+
+and num_of_nat nat =
+  if (is_nat_int nat 0 (length_nat nat)) 
+  then Int (nth_digit_nat nat 0)
+  else Big_int (big_int_of_nat nat)
+
+(* Coercion with big_int type *)
+let big_int_of_num = function
+  Int i -> big_int_of_int i
+| Big_int bi -> bi
+| Ratio r -> big_int_of_ratio r
+
+(* Coercion with ratio type *)
+let ratio_of_num = function
+  Int i -> ratio_of_int i
+| Big_int bi -> ratio_of_big_int bi
+| Ratio r -> r;;
+
+let string_of_big_int_for_num bi =
+  if !approx_printing_flag 
+     then approx_big_int !floating_precision bi
+     else string_of_big_int bi
+
+(* Coercion with string type *)
+
+(* XL: suppression de sys_string_of_num *)
+
+let string_of_normalized_num = function
+  Int i -> string_of_int i
+| Big_int bi -> string_of_big_int_for_num bi
+| Ratio r -> string_of_ratio r 
+let string_of_num n =
+    string_of_normalized_num (cautious_normalize_num_when_printing n)
+let num_of_string s =
+  try
+    let flag = !normalize_ratio_flag in
+    normalize_ratio_flag := true;
+    let r = ratio_of_string s in
+    normalize_ratio_flag := flag;
+    if eq_big_int (denominator_ratio r) unit_big_int 
+    then num_of_big_int (numerator_ratio r)
+    else Ratio r
+  with Failure _ ->
+    failwith "num_of_string"
+
+(* Coercion with float type *)
+let float_of_num = function
+  Int i -> float i
+| Big_int bi -> float_of_big_int bi
+| Ratio r -> float_of_ratio r
+
+(* XL: suppression de num_of_float, float_num *)
+
+let succ_num = function
+  Int i -> if i = biggest_int
+              then Big_int (succ_big_int (big_int_of_int i))
+              else Int (succ i)
+| Big_int bi -> num_of_big_int (succ_big_int bi)
+| Ratio r -> Ratio (add_int_ratio 1 r)
+
+and pred_num = function
+  Int i -> if i = monster_int
+              then Big_int (pred_big_int (big_int_of_int i))
+              else Int (pred i)
+| Big_int bi -> num_of_big_int (pred_big_int bi)
+| Ratio r -> Ratio (add_int_ratio (-1) r)
+
+let abs_num = function
+   Int i -> if i = monster_int
+              then Big_int (minus_big_int (big_int_of_int i))
+              else Int (abs i)
+ | Big_int bi -> Big_int (abs_big_int bi)
+ | Ratio r -> Ratio (abs_ratio r)
+
+let approx_num_fix n num = approx_ratio_fix n (ratio_of_num num)
+and approx_num_exp n num = approx_ratio_exp n (ratio_of_num num)
+
+let incr_num r = r := succ_num !r
+and decr_num r = r := pred_num !r
+
+
+
+
+
diff --git a/otherlibs/num/num.mli b/otherlibs/num/num.mli
new file mode 100644
index 00000000..cd4d8ea2
--- /dev/null
+++ b/otherlibs/num/num.mli
@@ -0,0 +1,171 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: num.mli,v 1.8 2001/12/28 23:15:23 guesdon Exp $ *)
+
+(** Operation on arbitrary-precision numbers.
+
+   Numbers (type [num]) are arbitrary-precision rational numbers,
+   plus the special elements [1/0] (infinity) and [0/0] (undefined). 
+*)
+
+open Nat
+open Big_int
+open Ratio
+
+(** The type of numbers. *)
+type num = 
+    Int of int
+  | Big_int of big_int
+  | Ratio of ratio
+
+
+(** {6 Arithmetic operations} *)
+
+
+val ( +/ ) : num -> num -> num
+(** Same as {!Num.add_num}.*)
+
+val add_num : num -> num -> num
+(** Addition *)
+
+val minus_num : num -> num
+(** Unary negation. *)
+
+val ( -/ ) : num -> num -> num
+(** Same as {!Num.sub_num}.*)
+
+val sub_num : num -> num -> num
+(** Subtraction *)
+
+val ( */ ) : num -> num -> num
+(** Same as {!Num.mult_num}.*)
+
+val mult_num : num -> num -> num
+(** Multiplication *)
+
+val square_num : num -> num
+(** Squaring *)
+
+val ( // ) : num -> num -> num
+(** Same as {!Num.div_num}.*)
+
+val div_num : num -> num -> num
+(** Division *)
+
+val quo_num : num -> num -> num
+(** Euclidean division: quotient. *)
+
+val mod_num : num -> num -> num
+(** Euclidean division: remainder. *)
+
+val ( **/ ) : num -> num -> num
+(** Same as {!Num.power_num}. *)
+
+val power_num : num -> num -> num
+(** Exponentiation *)
+
+val abs_num : num -> num
+(** Absolute value. *)
+
+val succ_num : num -> num
+(** [succ n] is [n+1] *)
+
+val pred_num : num -> num
+(** [pred n] is [n-1] *)
+
+val incr_num : num ref -> unit
+(** [incr r] is [r:=!r+1], where [r] is a reference to a number. *)
+
+val decr_num : num ref -> unit
+(** [decr r] is [r:=!r-1], where [r] is a reference to a number. *)
+
+val is_integer_num : num -> bool
+(** Test if a number is an integer *)
+
+(** The four following functions approximate a number by an integer : *)
+
+val integer_num : num -> num
+(** [integer_num n] returns the integer closest to [n]. In case of ties, 
+   rounds towards zero. *)
+
+val floor_num : num -> num
+(** [floor_num n] returns the largest integer smaller or equal to [n]. *)
+
+val round_num : num -> num
+(** [round_num n] returns the integer closest to [n]. In case of ties,
+   rounds off zero. *)
+
+val ceiling_num : num -> num
+(** [ceiling_num n] returns the smallest integer bigger or equal to [n]. *)
+
+
+val sign_num : num -> int
+(** Return [-1], [0] or [1] according to the sign of the argument. *)
+
+(** {7 Comparisons between numbers} *)
+
+val ( =/ ) : num -> num -> bool
+val ( </ ) : num -> num -> bool
+val ( >/ ) : num -> num -> bool
+val ( <=/ ) : num -> num -> bool
+val ( >=/ ) : num -> num -> bool
+val ( <>/ ) : num -> num -> bool
+val eq_num : num -> num -> bool
+val lt_num : num -> num -> bool
+val le_num : num -> num -> bool
+val gt_num : num -> num -> bool
+val ge_num : num -> num -> bool
+
+val compare_num : num -> num -> int
+(** Return [-1], [0] or [1] if the first argument is less than,
+   equal to, or greater than the second argument. *)
+
+val max_num : num -> num -> num
+(** Return the greater of the two arguments. *)
+
+val min_num : num -> num -> num
+(** Return the smaller of the two arguments. *)
+
+
+(** {6 Coercions with strings} *)
+
+val string_of_num : num -> string
+(** Convert a number to a string, using fractional notation. *)
+
+val approx_num_fix : int -> num -> string
+(** See {!Num.approx_num_exp}.*)
+
+val approx_num_exp : int -> num -> string
+(** Approximate a number by a decimal. The first argument is the
+   required precision. The second argument is the number to
+   approximate. {!Num.approx_num_fix} uses decimal notation; the first
+   argument is the number of digits after the decimal point.
+   [approx_num_exp] uses scientific (exponential) notation; the
+   first argument is the number of digits in the mantissa. *)
+
+val num_of_string : string -> num
+(** Convert a string to a number. *)
+
+(** {6 Coercions between numerical types} *)
+
+val int_of_num : num -> int
+val num_of_int : int -> num
+val nat_of_num : num -> nat
+val num_of_nat : nat -> num
+val num_of_big_int : big_int -> num
+val big_int_of_num : num -> big_int
+val ratio_of_num : num -> ratio
+val num_of_ratio : ratio -> num
+val float_of_num : num -> float
+
diff --git a/otherlibs/num/ratio.ml b/otherlibs/num/ratio.ml
new file mode 100644
index 00000000..50023642
--- /dev/null
+++ b/otherlibs/num/ratio.ml
@@ -0,0 +1,577 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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.  *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Int_misc
+open String_misc
+open Nat
+open Big_int
+open Arith_flags
+
+(* Definition of the type ratio :
+   Conventions :                                 
+   - the denominator is always a positive number 
+   - the sign of n/0 is the sign of n            
+These convention is automatically respected when a ratio is created with 
+the create_ratio primitive
+*)
+
+type ratio = { mutable numerator : big_int; 
+               mutable denominator : big_int; 
+               mutable normalized : bool}
+
+let failwith_zero name = 
+    let s = "infinite or undefined rational number" in
+    failwith (if String.length name = 0 then s else name ^ " " ^ s)
+
+let numerator_ratio r = r.numerator
+and denominator_ratio r = r.denominator
+
+let null_denominator r = sign_big_int r.denominator = 0
+
+let verify_null_denominator r = 
+  if sign_big_int r.denominator = 0
+     then (if !error_when_null_denominator_flag
+           then (failwith_zero "")
+           else true)
+     else false
+
+let sign_ratio r = sign_big_int r.numerator 
+
+(* Physical normalization of rational numbers *)
+(* 1/0, 0/0 and -1/0 are the normalized forms for n/0 numbers *)
+let normalize_ratio r = 
+  if r.normalized then r
+  else if verify_null_denominator r then begin
+    r.numerator <- big_int_of_int (sign_big_int r.numerator);
+    r.normalized <- true;
+    r
+  end else begin
+    let p = gcd_big_int r.numerator r.denominator in
+    if eq_big_int p unit_big_int 
+    then begin
+      r.normalized <- true; r
+    end else begin
+      r.numerator <- div_big_int (r.numerator) p; 
+      r.denominator <- div_big_int (r.denominator) p; 
+      r.normalized <- true; r
+    end
+  end
+
+let cautious_normalize_ratio r =
+ if (!normalize_ratio_flag) then (normalize_ratio r) else r
+
+let cautious_normalize_ratio_when_printing r =
+ if (!normalize_ratio_when_printing_flag) then (normalize_ratio r) else r
+
+let create_ratio bi1 bi2 =
+ match sign_big_int bi2 with 
+       -1 -> cautious_normalize_ratio
+               { numerator = minus_big_int bi1; 
+                 denominator = minus_big_int bi2;
+                 normalized = false }
+     | 0 -> if !error_when_null_denominator_flag 
+                then (failwith_zero "create_ratio")
+                else cautious_normalize_ratio 
+                    { numerator = bi1; denominator = bi2; normalized = false }
+     | _ ->  cautious_normalize_ratio 
+              { numerator = bi1; denominator = bi2; normalized = false }
+
+let create_normalized_ratio bi1 bi2 =
+ match sign_big_int bi2 with
+  -1 -> { numerator = minus_big_int bi1; 
+          denominator = minus_big_int bi2; 
+          normalized = true }
+|  0 -> if !error_when_null_denominator_flag 
+            then failwith_zero "create_normalized_ratio"
+            else { numerator = bi1; denominator = bi2; normalized = true }
+|  _  -> { numerator = bi1; denominator = bi2; normalized = true }
+
+let is_normalized_ratio r = r.normalized
+
+let report_sign_ratio r bi =
+  if sign_ratio r = -1
+  then minus_big_int bi 
+  else bi
+
+let abs_ratio r = 
+ { numerator = abs_big_int r.numerator;
+   denominator = r.denominator;
+   normalized = r.normalized }
+
+let is_integer_ratio r =
+ eq_big_int ((normalize_ratio r).denominator) unit_big_int
+
+(* Operations on rational numbers *)
+
+let add_ratio r1 r2 =
+ if !normalize_ratio_flag then begin
+    let p = gcd_big_int ((normalize_ratio r1).denominator) 
+                        ((normalize_ratio r2).denominator) in
+    if eq_big_int p unit_big_int then 
+       {numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator) 
+                                (mult_big_int (r2.numerator) r1.denominator);
+        denominator = mult_big_int (r1.denominator) r2.denominator;
+        normalized = true}
+    else begin
+      let d1 = div_big_int (r1.denominator) p
+      and d2 = div_big_int (r2.denominator) p in
+      let n = add_big_int (mult_big_int (r1.numerator) d2) 
+                          (mult_big_int d1 r2.numerator) in
+      let p' = gcd_big_int n p in
+        { numerator = div_big_int n p';
+          denominator = mult_big_int d1 (div_big_int (r2.denominator) p');
+          normalized = true }
+      end
+ end else
+  { numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator) 
+                            (mult_big_int (r1.denominator) r2.numerator);
+    denominator = mult_big_int (r1.denominator) r2.denominator;
+    normalized = false }
+
+let minus_ratio r =
+ { numerator = minus_big_int (r.numerator);
+   denominator = r.denominator;
+   normalized = r.normalized }
+
+let add_int_ratio i r = 
+  cautious_normalize_ratio r;
+  { numerator = add_big_int (mult_int_big_int i r.denominator) r.numerator;
+    denominator = r.denominator;
+    normalized = r.normalized }
+
+let add_big_int_ratio bi r = 
+  cautious_normalize_ratio r;
+  { numerator = add_big_int (mult_big_int bi r.denominator) r.numerator ;
+    denominator = r.denominator;
+    normalized = r.normalized }
+
+let sub_ratio r1 r2 = add_ratio r1 (minus_ratio r2)
+
+let mult_ratio r1 r2 =
+ if !normalize_ratio_flag then begin
+   let p1 = gcd_big_int ((normalize_ratio r1).numerator) 
+                        ((normalize_ratio r2).denominator) 
+   and p2 = gcd_big_int (r2.numerator) r1.denominator in
+   let (n1, d2) = 
+     if eq_big_int p1 unit_big_int 
+         then (r1.numerator, r2.denominator)
+         else (div_big_int (r1.numerator) p1, div_big_int (r2.denominator) p1)
+   and (n2, d1) =
+      if eq_big_int p2 unit_big_int 
+         then (r2.numerator, r1.denominator)
+         else (div_big_int r2.numerator p2, div_big_int r1.denominator p2) in
+    { numerator = mult_big_int n1 n2;
+      denominator = mult_big_int d1 d2;
+      normalized = true }
+ end else
+  { numerator = mult_big_int (r1.numerator) r2.numerator;
+    denominator = mult_big_int (r1.denominator) r2.denominator;
+    normalized = false }
+
+let mult_int_ratio i r = 
+ if !normalize_ratio_flag then
+  begin
+   let p = gcd_big_int ((normalize_ratio r).denominator) (big_int_of_int i) in
+   if eq_big_int p unit_big_int 
+      then { numerator = mult_big_int (big_int_of_int i) r.numerator;
+             denominator = r.denominator;
+             normalized = true }
+      else { numerator = mult_big_int (div_big_int (big_int_of_int i) p) 
+                                      r.numerator;
+             denominator = div_big_int (r.denominator) p;
+             normalized = true }
+  end
+ else
+  { numerator = mult_int_big_int i r.numerator;
+    denominator = r.denominator;
+    normalized = false }
+
+let mult_big_int_ratio bi r = 
+ if !normalize_ratio_flag then 
+  begin
+   let p = gcd_big_int ((normalize_ratio r).denominator) bi in
+     if eq_big_int p unit_big_int
+        then { numerator = mult_big_int bi r.numerator;
+               denominator = r.denominator;
+               normalized = true }
+        else { numerator = mult_big_int (div_big_int bi p) r.numerator;
+               denominator = div_big_int (r.denominator) p;
+               normalized = true }
+  end
+ else
+  { numerator = mult_big_int bi r.numerator;
+      denominator = r.denominator;
+      normalized = false }
+
+let square_ratio r =
+  cautious_normalize_ratio r;
+  { numerator = square_big_int r.numerator;
+    denominator = square_big_int r.denominator;
+    normalized = r.normalized }
+
+let inverse_ratio r =
+  if !error_when_null_denominator_flag && (sign_big_int r.numerator) = 0
+  then failwith_zero "inverse_ratio"
+  else {numerator = report_sign_ratio r r.denominator; 
+        denominator = abs_big_int r.numerator; 
+        normalized = r.normalized}
+
+let div_ratio r1 r2 = 
+  mult_ratio r1 (inverse_ratio r2)
+
+(* Integer part of a rational number *)
+(* Odd function *)
+let integer_ratio r = 
+ if null_denominator r then failwith_zero "integer_ratio"
+ else if sign_ratio r = 0 then zero_big_int
+ else report_sign_ratio r (div_big_int (abs_big_int r.numerator) 
+                                       (abs_big_int r.denominator))
+
+(* Floor of a rational number *)
+(* Always less or equal to r *)
+let floor_ratio r = 
+ verify_null_denominator r;
+ div_big_int (r.numerator) r.denominator
+
+(* Round of a rational number *)
+(* Odd function, 1/2 -> 1 *)
+let round_ratio r =
+ verify_null_denominator r;
+  let abs_num = abs_big_int r.numerator in
+   let bi = div_big_int abs_num r.denominator in
+    report_sign_ratio r 
+     (if sign_big_int 
+          (sub_big_int 
+           (mult_int_big_int 
+             2 
+             (sub_big_int abs_num (mult_big_int (r.denominator) bi))) 
+           r.denominator) = -1
+      then bi
+      else succ_big_int bi)
+
+let ceiling_ratio r = 
+ if (is_integer_ratio r)
+ then r.numerator
+ else succ_big_int (floor_ratio r)
+
+
+(* Comparison operators on rational numbers *)
+let eq_ratio r1 r2 =
+ normalize_ratio r1; 
+ normalize_ratio r2;
+ eq_big_int (r1.numerator) r2.numerator &&
+ eq_big_int (r1.denominator) r2.denominator 
+
+let compare_ratio r1 r2 =
+  if verify_null_denominator r1 then
+        let sign_num_r1 = sign_big_int r1.numerator in
+         if (verify_null_denominator r2)
+          then 
+           let sign_num_r2 = sign_big_int r2.numerator in
+             if sign_num_r1 = 1 && sign_num_r2 = -1 then  1 
+             else if sign_num_r1 = -1 && sign_num_r2 = 1 then -1
+             else 0
+         else sign_num_r1
+  else if verify_null_denominator r2 then
+          -(sign_big_int r2.numerator)
+  else match compare_int (sign_big_int r1.numerator) 
+                         (sign_big_int r2.numerator) with
+               1 -> 1
+             | -1 -> -1
+             | _ -> if eq_big_int (r1.denominator) r2.denominator 
+                    then compare_big_int (r1.numerator) r2.numerator
+                    else compare_big_int 
+                            (mult_big_int (r1.numerator) r2.denominator) 
+                            (mult_big_int (r1.denominator) r2.numerator)
+     
+
+let lt_ratio r1 r2 = compare_ratio r1 r2 < 0
+and le_ratio r1 r2 = compare_ratio r1 r2 <= 0
+and gt_ratio r1 r2 = compare_ratio r1 r2 > 0
+and ge_ratio r1 r2 = compare_ratio r1 r2 >= 0
+
+let max_ratio r1 r2 = if lt_ratio r1 r2 then r2 else r1
+and min_ratio r1 r2 = if gt_ratio r1 r2 then r2 else r1
+
+let eq_big_int_ratio bi r =
+ (is_integer_ratio r) && eq_big_int bi r.numerator
+
+let compare_big_int_ratio bi r =
+ normalize_ratio r;
+ if (verify_null_denominator r)
+ then -(sign_big_int r.numerator)
+ else compare_big_int (mult_big_int bi r.denominator) r.numerator
+
+let lt_big_int_ratio bi r = compare_big_int_ratio bi r < 0
+and le_big_int_ratio bi r = compare_big_int_ratio bi r <= 0
+and gt_big_int_ratio bi r = compare_big_int_ratio bi r > 0
+and ge_big_int_ratio bi r = compare_big_int_ratio bi r >= 0
+
+(* Coercions *)
+
+(* Coercions with type int *)
+let int_of_ratio r = 
+ if ((is_integer_ratio r) && (is_int_big_int r.numerator))
+ then (int_of_big_int r.numerator)
+ else failwith "integer argument required"
+
+and ratio_of_int i =
+ { numerator = big_int_of_int i; 
+   denominator = unit_big_int;
+   normalized = true }
+
+(* Coercions with type nat *)
+let ratio_of_nat nat = 
+ { numerator = big_int_of_nat nat;
+   denominator = unit_big_int;
+   normalized = true }
+
+and nat_of_ratio r =
+ normalize_ratio r;
+ if not (is_integer_ratio r) then
+          failwith "nat_of_ratio"
+ else if sign_big_int r.numerator > -1 then
+         nat_of_big_int (r.numerator)
+ else failwith "nat_of_ratio"
+
+(* Coercions with type big_int *)
+let ratio_of_big_int bi = 
+ { numerator = bi; denominator = unit_big_int; normalized = true }
+
+and big_int_of_ratio r =
+ normalize_ratio r;
+ if is_integer_ratio r 
+  then r.numerator
+ else failwith "big_int_of_ratio"
+
+let div_int_ratio i r = 
+  verify_null_denominator r;
+  mult_int_ratio i (inverse_ratio r)
+
+let div_ratio_int r i = 
+  div_ratio r (ratio_of_int i)
+
+let div_big_int_ratio bi r = 
+  verify_null_denominator r;
+  mult_big_int_ratio bi (inverse_ratio r)
+
+let div_ratio_big_int r bi = 
+  div_ratio r (ratio_of_big_int bi)
+
+(* Functions on type string                                 *)
+(* giving floating point approximations of rational numbers *)
+
+(* Compares strings that contains only digits, have the same length,
+   from index i to index i + l *)
+let rec compare_num_string s1 s2 i len =
+ if i >= len then 0 else
+ let c1 = int_of_char s1.[i]
+ and c2 = int_of_char s2.[i] in
+ match compare_int c1 c2 with
+ | 0 -> compare_num_string s1 s2 (succ i) len
+ | c -> c;;
+
+(* Position of the leading digit of the decimal expansion          *)
+(* of a strictly positive rational number                          *)
+(* if the decimal expansion of a non null rational r is equal to   *)
+(* sigma for k=-P to N of r_k*10^k then msd_ratio r = N            *)
+(* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *)
+
+(* Tests if s has only zeros characters from index i to index lim *)
+let rec only_zeros s i lim =
+ i >= lim || s.[i] == '0' && only_zeros s (succ i) lim;;
+
+(* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *)
+let msd_ratio r =
+ cautious_normalize_ratio r;
+ if null_denominator r then failwith_zero "msd_ratio"
+ else if sign_big_int r.numerator == 0 then 0
+ else begin
+         let str_num = string_of_big_int r.numerator
+         and str_den = string_of_big_int r.denominator in
+         let size_num = String.length str_num
+         and size_den = String.length str_den in
+         let size_min = min size_num size_den in
+         let m = size_num - size_den in
+         let cmp = compare_num_string str_num str_den 0 size_min in
+         match cmp with
+         | 1 -> m
+         | -1 -> pred m
+         | _ ->
+           if m >= 0 then m else
+           if only_zeros str_den size_min size_den then m
+           else pred m
+      end
+;;
+
+(* Decimal approximations of rational numbers *)
+
+(* Approximation with fix decimal point *)
+(* This is an odd function and the last digit is round off *)
+(* Format integer_part . decimal_part_with_n_digits *)
+let approx_ratio_fix n r =
+ (* Don't need to normalize *)
+ if (null_denominator r) then failwith_zero "approx_ratio_fix"
+ else
+  let sign_r = sign_ratio r in 
+   if sign_r = 0
+   then "+0" (* r = 0 *)
+   else (* r.numerator and r.denominator are not null numbers 
+           s contains one more digit than desired for the round off operation
+           and to have enough room in s when including the decimal point *)
+    if n >= 0 then 
+        let s = 
+         let nat = 
+           (nat_of_big_int
+                (div_big_int
+                   (base_power_big_int
+                       10 (succ n) (abs_big_int r.numerator))
+                   r.denominator))
+         in (if sign_r = -1 then "-" else "+") ^ string_of_nat nat in
+        let l = String.length s in
+         if round_futur_last_digit s 1 (pred l) 
+          then begin (* if one more char is needed in s *)
+           let str = (String.make (succ l) '0') in 
+            String.set str 0 (if sign_r = -1 then '-' else '+');
+            String.set str 1 '1';
+            String.set str (l - n) '.';
+            str
+          end else (* s can contain the final result *)
+           if l > n + 2
+            then begin (* |r| >= 1, set decimal point *)
+             let l2 = (pred l) - n in
+               String.blit s l2 s (succ l2) n; 
+               String.set s l2 '.'; s
+            end else begin (* |r| < 1, there must be 0-characters *)
+                           (* before the significant development, *)
+                           (* with care to the sign of the number *)
+             let size = n + 3 in
+             let m = size - l + 2
+             and str = String.make size '0' in
+
+              (String.blit (if sign_r = 1 then "+0." else "-0.") 0 str 0 3);
+              (String.blit s 1 str m (l - 2));
+              str
+            end
+       else begin
+         let s = string_of_big_int
+                   (div_big_int
+                      (abs_big_int r.numerator) 
+                      (base_power_big_int
+                        10 (-n) r.denominator)) in
+         let len = succ (String.length s) in
+         let s' = String.make len '0' in
+          String.set s' 0 (if sign_r = -1 then '-' else '+');
+          String.blit s 0 s' 1 (pred len);
+          s'
+       end
+
+(* Number of digits of the decimal representation of an int *)
+let num_decimal_digits_int n = 
+  String.length (string_of_int n)
+
+(* Approximation with floating decimal point *)
+(* This is an odd function and the last digit is round off *)
+(* Format (+/-)(0. n_first_digits e msd)/(1. n_zeros e (msd+1) *)
+let approx_ratio_exp n r = 
+ (* Don't need to normalize *)
+ if (null_denominator r) then failwith_zero "approx_ratio_exp"
+ else if n <= 0 then invalid_arg "approx_ratio_exp"
+ else
+  let sign_r = sign_ratio r
+  and i = ref (n + 3) in
+   if sign_r = 0
+     then
+      let s = String.make (n + 5) '0' in
+       (String.blit "+0." 0 s 0 3);
+       (String.blit "e0" 0 s !i 2); s
+   else 
+     let msd = msd_ratio (abs_ratio r) in
+     let k = n - msd in
+     let s = 
+      (let nat = nat_of_big_int
+                (if k < 0
+                  then 
+                   div_big_int (abs_big_int r.numerator) 
+                               (base_power_big_int 10 (- k) 
+                                                   r.denominator)
+                 else 
+                  div_big_int (base_power_big_int
+                                10 k (abs_big_int r.numerator))
+                               r.denominator) in
+       string_of_nat nat) in
+     if (round_futur_last_digit s 0 (String.length s)) 
+      then
+       let m = num_decimal_digits_int (succ msd) in
+       let str = String.make (n + m + 4) '0' in
+         (String.blit (if sign_r = -1 then "-1." else "+1.") 0 str 0 3);
+         String.set str !i ('e');
+         incr i;
+         (if m = 0
+          then String.set str !i '0' 
+          else String.blit (string_of_int (succ msd)) 0 str !i m); 
+         str
+     else
+      let m = num_decimal_digits_int (succ msd)
+      and p = n + 3 in
+      let str = String.make (succ (m + p)) '0' in
+        (String.blit (if sign_r = -1 then "-0." else "+0.") 0 str 0 3);
+        (String.blit s 0 str 3 n);
+        String.set str p 'e';
+        (if m = 0
+          then String.set str (succ p) '0'
+          else (String.blit (string_of_int (succ msd)) 0 str (succ p) m));
+        str
+
+(* String approximation of a rational with a fixed number of significant *)
+(* digits printed                                                        *)
+let float_of_rational_string r = 
+  let s = approx_ratio_exp !floating_precision r in
+    if String.get s 0 = '+'
+       then (String.sub s 1 (pred (String.length s)))
+       else s
+
+(* Coercions with type string *)
+let string_of_ratio r = 
+ cautious_normalize_ratio_when_printing r;
+ if !approx_printing_flag
+    then float_of_rational_string r
+    else string_of_big_int r.numerator ^ "/" ^ string_of_big_int r.denominator
+
+(* XL: j'ai puissamment simplifie "ratio_of_string" en virant la notation
+   scientifique. *)
+
+let ratio_of_string s =
+  let n = index_char s '/' 0 in
+  if n = -1 then
+    { numerator = big_int_of_string s;
+      denominator = unit_big_int;
+      normalized = true }
+  else
+    create_ratio (sys_big_int_of_string s 0 n)
+                 (sys_big_int_of_string s (n+1) (String.length s - n - 1))
+
+(* Coercion with type float *)
+
+let float_of_ratio r =
+  float_of_string (float_of_rational_string r)
+
+(* XL: suppression de ratio_of_float *)
+
+let power_ratio_positive_int r n = 
+  create_ratio (power_big_int_positive_int (r.numerator) n) 
+               (power_big_int_positive_int (r.denominator) n)
+
+let power_ratio_positive_big_int r bi = 
+  create_ratio (power_big_int_positive_big_int (r.numerator) bi) 
+               (power_big_int_positive_big_int (r.denominator) bi)
diff --git a/otherlibs/num/ratio.mli b/otherlibs/num/ratio.mli
new file mode 100644
index 00000000..d6c2aff2
--- /dev/null
+++ b/otherlibs/num/ratio.mli
@@ -0,0 +1,88 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA 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: ratio.mli,v 1.4 2001/12/07 13:40:16 xleroy Exp $ *)
+
+(* Module [Ratio]: operations on rational numbers *)
+
+open Nat
+open Big_int
+
+(* Rationals (type [ratio]) are arbitrary-precision rational numbers,
+   plus the special elements [1/0] (infinity) and [0/0] (undefined).
+   In constrast with numbers (type [num]), the special cases of
+   small integers and big integers are not optimized specially. *)
+
+type ratio
+
+val null_denominator : ratio -> bool
+val numerator_ratio : ratio -> big_int
+val denominator_ratio : ratio -> big_int
+val sign_ratio : ratio -> int
+val normalize_ratio : ratio -> ratio
+val cautious_normalize_ratio : ratio -> ratio
+val cautious_normalize_ratio_when_printing : ratio -> ratio
+val create_ratio : big_int -> big_int -> ratio
+val create_normalized_ratio : big_int -> big_int -> ratio
+val is_normalized_ratio : ratio -> bool
+val report_sign_ratio : ratio -> big_int -> big_int
+val abs_ratio : ratio -> ratio
+val is_integer_ratio : ratio -> bool
+val add_ratio : ratio -> ratio -> ratio
+val minus_ratio : ratio -> ratio
+val add_int_ratio : int -> ratio -> ratio
+val add_big_int_ratio : big_int -> ratio -> ratio
+val sub_ratio : ratio -> ratio -> ratio
+val mult_ratio : ratio -> ratio -> ratio
+val mult_int_ratio : int -> ratio -> ratio
+val mult_big_int_ratio : big_int -> ratio -> ratio
+val square_ratio : ratio -> ratio
+val inverse_ratio : ratio -> ratio
+val div_ratio : ratio -> ratio -> ratio
+val integer_ratio : ratio -> big_int
+val floor_ratio : ratio -> big_int
+val round_ratio : ratio -> big_int
+val ceiling_ratio : ratio -> big_int
+val eq_ratio : ratio -> ratio -> bool
+val compare_ratio : ratio -> ratio -> int
+val lt_ratio : ratio -> ratio -> bool
+val le_ratio : ratio -> ratio -> bool
+val gt_ratio : ratio -> ratio -> bool
+val ge_ratio : ratio -> ratio -> bool
+val max_ratio : ratio -> ratio -> ratio
+val min_ratio : ratio -> ratio -> ratio
+val eq_big_int_ratio : big_int -> ratio -> bool
+val compare_big_int_ratio : big_int -> ratio -> int
+val lt_big_int_ratio : big_int -> ratio -> bool
+val le_big_int_ratio : big_int -> ratio -> bool
+val gt_big_int_ratio : big_int -> ratio -> bool
+val ge_big_int_ratio : big_int -> ratio -> bool
+val int_of_ratio : ratio -> int
+val ratio_of_int : int -> ratio
+val ratio_of_nat : nat -> ratio
+val nat_of_ratio : ratio -> nat
+val ratio_of_big_int : big_int -> ratio
+val big_int_of_ratio : ratio -> big_int
+val div_int_ratio : int -> ratio -> ratio
+val div_ratio_int : ratio -> int -> ratio
+val div_big_int_ratio : big_int -> ratio -> ratio
+val div_ratio_big_int : ratio -> big_int -> ratio
+val approx_ratio_fix : int -> ratio -> string
+val approx_ratio_exp : int -> ratio -> string
+val float_of_rational_string : ratio -> string
+val string_of_ratio : ratio -> string
+val ratio_of_string : string -> ratio
+val float_of_ratio : ratio -> float
+val power_ratio_positive_int : ratio -> int -> ratio
+val power_ratio_positive_big_int : ratio -> big_int -> ratio
+
diff --git a/otherlibs/macosunix/macosunix_startup.ml b/otherlibs/num/string_misc.ml
similarity index 67%
rename from otherlibs/macosunix/macosunix_startup.ml
rename to otherlibs/num/string_misc.ml
index 3a602c43..e19e46eb 100644
--- a/otherlibs/macosunix/macosunix_startup.ml
+++ b/otherlibs/num/string_misc.ml
@@ -2,16 +2,19 @@
 (*                                                                     *)
 (*                           Objective Caml                            *)
 (*                                                                     *)
-(*           Damien Doligez, projet Moscova, INRIA Rocquencourt        *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
-(*  Copyright 2000 Institut National de Recherche en Informatique et   *)
+(*  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: macosunix_startup.ml,v 1.2 2001/12/07 13:40:13 xleroy Exp $ *)
+(* $Id: string_misc.ml,v 1.4 2001/12/07 13:40:16 xleroy Exp $ *)
 
-external startup : unit -> unit = "macosunix_startup";;
-startup ();;
+let rec index_char str chr pos =
+  if pos >= String.length str then -1
+  else if String.get str pos = chr then pos
+  else index_char str chr (pos + 1)
+;;
diff --git a/otherlibs/macosunix/macosunix_startup.mli b/otherlibs/num/string_misc.mli
similarity index 74%
rename from otherlibs/macosunix/macosunix_startup.mli
rename to otherlibs/num/string_misc.mli
index 3ea8ab9d..079c951e 100644
--- a/otherlibs/macosunix/macosunix_startup.mli
+++ b/otherlibs/num/string_misc.mli
@@ -2,15 +2,15 @@
 (*                                                                     *)
 (*                           Objective Caml                            *)
 (*                                                                     *)
-(*           Damien Doligez, projet Moscova, INRIA Rocquencourt        *)
+(*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
-(*  Copyright 2000 Institut National de Recherche en Informatique et   *)
+(*  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: macosunix_startup.mli,v 1.2 2001/12/07 13:40:13 xleroy Exp $ *)
+(* $Id: string_misc.mli,v 1.4 2001/12/07 13:40:17 xleroy Exp $ *)
 
-(* This file left blank intentionally. *)
+val index_char: string -> char -> int -> int
diff --git a/otherlibs/num/test/.depend b/otherlibs/num/test/.depend
new file mode 100644
index 00000000..28fea1f5
--- /dev/null
+++ b/otherlibs/num/test/.depend
@@ -0,0 +1,10 @@
+end_test.cmo: test.cmo 
+end_test.cmx: test.cmx 
+test_big_ints.cmo: test.cmo 
+test_big_ints.cmx: test.cmx 
+test_nats.cmo: test.cmo 
+test_nats.cmx: test.cmx 
+test_nums.cmo: test.cmo 
+test_nums.cmx: test.cmx 
+test_ratios.cmo: test.cmo 
+test_ratios.cmx: test.cmx 
diff --git a/otherlibs/num/test/Makefile b/otherlibs/num/test/Makefile
new file mode 100644
index 00000000..c591d0c6
--- /dev/null
+++ b/otherlibs/num/test/Makefile
@@ -0,0 +1,61 @@
+#########################################################################
+#                                                                       #
+#                            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.9 2003/10/24 09:17:46 xleroy Exp $
+
+include ../../../config/Makefile
+
+CAMLC=../../../boot/ocamlrun ../../../ocamlc -I ../../../stdlib
+CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I ../../../stdlib
+CC=$(BYTECC)
+CFLAGS=-I.. $(BYTECCCOMPOPTS)
+
+test: test.byt test.opt
+	if $(SUPPORTS_SHARED_LIBRARIES); then ../../../byterun/ocamlrun -I .. ./test.byt; else ./test.byt; fi
+	./test.opt
+
+TESTFILES=test.cmo \
+  test_nats.cmo test_big_ints.cmo test_ratios.cmo test_nums.cmo \
+  test_io.cmo end_test.cmo
+
+TESTOPTFILES=$(TESTFILES:.cmo=.cmx)
+
+test.byt: $(TESTFILES) ../nums.cma ../libnums.a
+	$(CAMLC) -ccopt -L.. -o test.byt ../nums.cma $(TESTFILES)
+
+test.opt: $(TESTOPTFILES) ../nums.cmxa ../libnums.a
+	$(CAMLOPT) -ccopt -L.. -o test.opt ../nums.cmxa $(TESTOPTFILES)
+
+test_bng: test_bng.o
+	$(CC) $(CFLAGS) -o test_bng ../bng.o test_bng.o -lbignum
+
+$(TESTOPTFILES): ../../../ocamlopt
+
+.SUFFIXES: .ml .cmo .cmx
+
+.ml.cmo:
+	$(CAMLC) -I .. -c $<
+
+.ml.cmx:
+	$(CAMLOPT) -I .. -c $<
+
+ocamlnum:
+	ocamlmktop -o ocamlnum -custom ../nums.cma ../libnums.a
+
+clean:
+	rm -f test.byt test.opt test_bng *.o *.cm? ocamlnum
+
+depend:
+	ocamldep *.ml > .depend
+
+include .depend
diff --git a/otherlibs/num/test/Makefile.nt b/otherlibs/num/test/Makefile.nt
new file mode 100644
index 00000000..3cb2e9c7
--- /dev/null
+++ b/otherlibs/num/test/Makefile.nt
@@ -0,0 +1,61 @@
+#########################################################################
+#                                                                       #
+#                            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.9 2004/04/01 13:10:12 xleroy Exp $
+
+include ../../../config/Makefile
+
+CAMLC=../../../boot/ocamlrun ../../../ocamlc -I ../../../stdlib -I ..
+CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I ../../../stdlib -I ..
+CC=$(BYTECC)
+CFLAGS=-I.. $(BYTECCCOMPOPTS)
+
+test: test.byt test.opt
+	../../../byterun/ocamlrun -I .. ./test.byt
+	./test.opt
+
+TESTFILES=test.cmo \
+  test_nats.cmo test_big_ints.cmo test_ratios.cmo test_nums.cmo \
+  test_io.cmo end_test.cmo
+
+TESTOPTFILES=$(TESTFILES:.cmo=.cmx)
+
+test.byt: $(TESTFILES) ../nums.cma ../libnums.$(A)
+	$(CAMLC) -o test.byt nums.cma $(TESTFILES)
+
+test.opt: $(TESTOPTFILES) ../nums.cmxa ../libnums.$(A)
+	$(CAMLOPT) -o test.opt nums.cmxa $(TESTOPTFILES)
+
+test_bng.exe: test_bng.o
+	$(CC) $(CFLAGS) -o test_bng.exe ../bng.o test_bng.o -lbignum
+
+$(TESTOPTFILES): ../../../ocamlopt
+
+.SUFFIXES: .ml .cmo .cmx
+
+.ml.cmo:
+	$(CAMLC) -c $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $<
+
+ocamltopnum.exe:
+	ocamlmktop -o ocamltopnum.exe -custom ../nums.cma ../libnums.$(A)
+
+clean:
+	rm -f test.byt test.opt test_bng.exe *.$(O) *.cm? ocamltopnum.exe
+
+depend:
+	ocamldep *.ml > .depend
+
+include .depend
diff --git a/otherlibs/num/test/end_test.ml b/otherlibs/num/test/end_test.ml
new file mode 100644
index 00000000..57e099ed
--- /dev/null
+++ b/otherlibs/num/test/end_test.ml
@@ -0,0 +1 @@
+Test.end_tests ();;
diff --git a/otherlibs/num/test/test.ml b/otherlibs/num/test/test.ml
new file mode 100644
index 00000000..8426e0ae
--- /dev/null
+++ b/otherlibs/num/test/test.ml
@@ -0,0 +1,77 @@
+open Printf;;
+
+let flush_all () = flush stdout; flush stderr;;
+
+let message s = print_string s; print_newline ();;
+
+let error_occurred = ref false;;
+let immediate_failure = ref true;;
+
+let error () =
+ if !immediate_failure then exit 2 else begin
+   error_occurred := true; flush_all (); false
+ end;;
+
+let success () = flush_all (); true;;
+
+let function_tested = ref "";;
+
+let testing_function s =
+    flush_all ();
+    function_tested := s;
+    print_newline();
+    message s;;
+
+let test test_number eq_fun (answer, correct_answer) =
+ flush_all ();
+ if not (eq_fun answer correct_answer) then begin
+   fprintf stderr ">>> Bad result (%s, test %d)\n" !function_tested test_number;
+   error ()
+ end else begin
+   printf " %d..." test_number;
+   success ()
+ end;;
+
+let failure_test test_number fun_to_test arg =
+ flush_all ();
+ try
+   fun_to_test arg;
+   fprintf stderr ">>> Failure expected (%s, test %d)\n"
+                  !function_tested test_number;
+   error ()
+  with _ ->
+   printf " %d..." test_number;
+   success ();;
+
+let failwith_test test_number fun_to_test arg correct_failure =
+ flush_all ();
+ try
+   fun_to_test arg;
+   fprintf stderr ">>> Failure expected (%s, test %d)\n"
+                  !function_tested test_number;
+   error ()
+  with x ->
+   if x = correct_failure then begin
+     printf " %d..." test_number;
+     success ()
+   end else begin
+     fprintf stderr ">>> Bad failure (%s, test %d)\n"
+                    !function_tested test_number;
+     error ()
+   end;;
+
+let end_tests () =
+ flush_all ();
+ print_newline ();
+ if !error_occurred then begin
+   prerr_endline "************* TESTS FAILED ****************"; exit 2
+ end else begin
+   prerr_endline "************* TESTS COMPLETED SUCCESSFULLY ****************";
+   exit 0
+ end;;
+
+let eq = (==);;
+let eq_int = (==);;
+let eq_string = (=);;
+
+let sixtyfour = (1 lsl 31) <> 0;;
diff --git a/otherlibs/num/test/test_big_ints.ml b/otherlibs/num/test/test_big_ints.ml
new file mode 100644
index 00000000..61e9ae4d
--- /dev/null
+++ b/otherlibs/num/test/test_big_ints.ml
@@ -0,0 +1,468 @@
+open Test;;
+open Nat;;
+open Big_int;;
+open Int_misc;;
+open List;;
+
+testing_function "compare_big_int";;
+
+test 1
+eq_int (compare_big_int zero_big_int zero_big_int, 0);;
+test 2
+eq_int (compare_big_int zero_big_int (big_int_of_int 1), (-1));;
+test 3
+eq_int (compare_big_int zero_big_int (big_int_of_int (-1)), 1);;
+test 4
+eq_int (compare_big_int (big_int_of_int 1) zero_big_int, 1);;
+test 5
+eq_int (compare_big_int (big_int_of_int (-1)) zero_big_int, (-1));;
+test 6
+eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 1), 0);;
+test 7
+eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), 0);;
+test 8
+eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int (-1)), 1);;
+test 9
+eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int 1), (-1));;
+test 10
+eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 2), (-1));;
+test 11
+eq_int (compare_big_int (big_int_of_int 2) (big_int_of_int 1), 1);;
+test 12
+eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), 1);;
+test 13
+eq_int (compare_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), (-1));;
+
+
+testing_function "pred_big_int";;
+
+test 1
+eq_big_int (pred_big_int zero_big_int, big_int_of_int (-1));;
+test 2
+eq_big_int (pred_big_int unit_big_int, zero_big_int);;
+test 3
+eq_big_int (pred_big_int (big_int_of_int (-1)), big_int_of_int (-2));;
+
+testing_function "succ_big_int";;
+
+test 1
+eq_big_int (succ_big_int zero_big_int, unit_big_int);;
+test 2
+eq_big_int (succ_big_int unit_big_int, big_int_of_int 2);;
+test 3
+eq_big_int (succ_big_int (big_int_of_int (-1)), zero_big_int);;
+
+testing_function "add_big_int";;
+
+test 1
+eq_big_int (add_big_int zero_big_int zero_big_int, zero_big_int);;
+test 2
+eq_big_int (add_big_int zero_big_int (big_int_of_int 1), 
+            big_int_of_int 1);;
+test 3
+eq_big_int (add_big_int (big_int_of_int 1) zero_big_int, 
+            big_int_of_int 1);;
+test 4
+eq_big_int (add_big_int zero_big_int (big_int_of_int (-1)), 
+            big_int_of_int (-1));;
+test 5
+eq_big_int (add_big_int (big_int_of_int (-1)) zero_big_int, 
+            big_int_of_int (-1));;
+test 6
+eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 1), 
+            big_int_of_int 2);;
+test 7
+eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 2), 
+            big_int_of_int 3);;
+test 8
+eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int 1), 
+            big_int_of_int 3);;
+test 9
+eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), 
+            big_int_of_int (-2));;
+test 10
+eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), 
+            big_int_of_int (-3));;
+test 11
+eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), 
+            big_int_of_int (-3));;
+test 12
+eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-1)), 
+            zero_big_int);;
+test 13
+eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 1), 
+            zero_big_int);;
+test 14
+eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-2)), 
+            big_int_of_int (-1));;
+test 15
+eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int 1), 
+            big_int_of_int (-1));;
+test 16
+eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 2), 
+            big_int_of_int 1);;
+test 17
+eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int (-1)), 
+            big_int_of_int 1);;
+
+
+testing_function "sub_big_int";;
+
+test 1
+eq_big_int (sub_big_int zero_big_int zero_big_int, zero_big_int);;
+test 2
+eq_big_int (sub_big_int zero_big_int (big_int_of_int 1), 
+            big_int_of_int (-1));;
+test 3
+eq_big_int (sub_big_int (big_int_of_int 1) zero_big_int, 
+            big_int_of_int 1);;
+test 4
+eq_big_int (sub_big_int zero_big_int (big_int_of_int (-1)), 
+            big_int_of_int 1);;
+test 5
+eq_big_int (sub_big_int (big_int_of_int (-1)) zero_big_int, 
+            big_int_of_int (-1));;
+test 6
+eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 1), 
+            zero_big_int);;
+test 7
+eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 2), 
+            big_int_of_int (-1));;
+test 8
+eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int 1), 
+            big_int_of_int 1);;
+test 9
+eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), 
+            zero_big_int);;
+test 10
+eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), 
+            big_int_of_int 1);;
+test 11
+eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), 
+            big_int_of_int (-1));;
+test 12
+eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-1)), 
+            big_int_of_int 2);;
+test 13
+eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 1), 
+            big_int_of_int (-2));;
+test 14
+eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-2)), 
+            big_int_of_int 3);;
+test 15
+eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int 1), 
+            big_int_of_int (-3));;
+test 16
+eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 2), 
+            big_int_of_int (-3));;
+test 17
+eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int (-1)), 
+            big_int_of_int 3);;
+
+testing_function "mult_int_big_int";;
+
+test 1
+eq_big_int (mult_int_big_int 0 (big_int_of_int 3), zero_big_int);;
+test 2
+eq_big_int (mult_int_big_int 1 (big_int_of_int 3), big_int_of_int 3);;
+test 3
+eq_big_int (mult_int_big_int 1 zero_big_int, zero_big_int);;
+test 4
+eq_big_int (mult_int_big_int 2 (big_int_of_int 3), big_int_of_int 6);;
+
+testing_function "mult_big_int";;
+
+test 1
+eq_big_int (mult_big_int zero_big_int zero_big_int, 
+            zero_big_int);;
+test 2
+eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int 3), 
+            big_int_of_int 6);;
+test 3
+eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int (-3)), 
+            big_int_of_int (-6));;
+test 4 
+eq_big_int (mult_big_int (big_int_of_string "12724951") 
+                         (big_int_of_string "81749606400"), 
+            big_int_of_string "1040259735709286400");;
+test 5 
+eq_big_int (mult_big_int (big_int_of_string "26542080") 
+                          (big_int_of_string "81749606400"), 
+            big_int_of_string "2169804593037312000");;
+
+testing_function "quomod_big_int";;
+
+let (quotient, modulo) =
+      quomod_big_int (big_int_of_int 1) (big_int_of_int 1) in
+ test 1 eq_big_int (quotient, big_int_of_int 1) &&
+ test 2 eq_big_int (modulo, zero_big_int);;
+
+let (quotient, modulo) =
+      quomod_big_int (big_int_of_int 1) (big_int_of_int (-1)) in
+ test 3 eq_big_int (quotient, big_int_of_int (-1)) &&
+ test 4 eq_big_int (modulo, zero_big_int);;
+
+let (quotient, modulo) = 
+      quomod_big_int (big_int_of_int (-1)) (big_int_of_int 1) in
+ test 5 eq_big_int (quotient, big_int_of_int (-1)) && 
+ test 6 eq_big_int (modulo, zero_big_int);;
+
+let (quotient, modulo) = 
+      quomod_big_int (big_int_of_int 3) (big_int_of_int 2) in
+ test 7 eq_big_int (quotient, big_int_of_int 1) && 
+ test 8 eq_big_int (modulo, big_int_of_int 1);;
+
+let (quotient, modulo) =
+      quomod_big_int (big_int_of_int 5) (big_int_of_int 3) in
+ test 9 eq_big_int (quotient, big_int_of_int 1) &&
+ test 10 eq_big_int (modulo, big_int_of_int 2);;
+
+let (quotient, modulo) =
+      quomod_big_int (big_int_of_int (-5)) (big_int_of_int 3) in
+ test 11 eq_big_int (quotient, big_int_of_int (-2)) &&
+ test 12 eq_big_int (modulo, big_int_of_int 1);;
+
+let (quotient, modulo) = 
+      quomod_big_int (big_int_of_int 1) (big_int_of_int 2) in
+ test 13 eq_big_int (quotient, zero_big_int) && 
+ test 14 eq_big_int (modulo, big_int_of_int 1);;
+
+let (quotient, modulo) = 
+      quomod_big_int (big_int_of_int (-1)) (big_int_of_int 3) in
+ test 15 eq_big_int (quotient, minus_big_int unit_big_int) &&
+ test 16 eq_big_int (modulo, big_int_of_int 2);;
+
+failwith_test 17
+(quomod_big_int (big_int_of_int 1)) zero_big_int
+Division_by_zero
+;;
+
+testing_function "gcd_big_int";;
+
+test 1
+eq_big_int (gcd_big_int zero_big_int zero_big_int, 
+            zero_big_int);;
+test 2
+eq_big_int (gcd_big_int zero_big_int (big_int_of_int 1), 
+            big_int_of_int 1);;
+test 3
+eq_big_int (gcd_big_int (big_int_of_int 1) zero_big_int, 
+            big_int_of_int 1);;
+test 4
+eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 2), 
+            big_int_of_int 1);;
+test 5
+eq_big_int (gcd_big_int (big_int_of_int 2) (big_int_of_int 1), 
+            big_int_of_int 1);;
+test 6
+eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 1), 
+            big_int_of_int 1);;
+test 7
+eq_big_int (gcd_big_int (big_int_of_int 9) (big_int_of_int 16), 
+            big_int_of_int 1);;
+test 8
+eq_big_int (gcd_big_int (big_int_of_int 12) (big_int_of_int 16), 
+            big_int_of_int 4);;
+
+for i = 9 to 28 do
+  let n1 = Random.int 1000000000
+  and n2 = Random.int 100000 in
+  let _ =
+    test i eq
+      (int_of_big_int (gcd_big_int (big_int_of_int n1) (big_int_of_int n2)),
+       gcd_int n1 n2) in
+  ()
+done;;
+
+testing_function "int_of_big_int";;
+
+test 1
+eq_int (int_of_big_int (big_int_of_int 1), 1);;
+
+
+testing_function "is_int_big_int";;
+
+test 1
+eq (is_int_big_int (big_int_of_int 1), true);;
+test 2
+eq (is_int_big_int (big_int_of_int (-1)), true);;
+test 3
+eq (is_int_big_int (succ_big_int (big_int_of_int biggest_int)), false);;
+test 4
+eq (int_of_big_int (big_int_of_int monster_int), monster_int);;
+(* Should be true *)
+test 5
+eq (is_int_big_int (big_int_of_string (string_of_int biggest_int)), true);;
+test 6
+eq (is_int_big_int (big_int_of_string (string_of_int least_int)), true);;
+test 7
+eq (is_int_big_int (big_int_of_string (string_of_int monster_int)), true);;
+
+(* Should be false *)
+(* Successor of biggest_int is not an int *)
+test 8
+eq (is_int_big_int (succ_big_int (big_int_of_int (biggest_int))), false);;
+test 9
+eq (is_int_big_int
+     (succ_big_int (succ_big_int (big_int_of_int (biggest_int)))), false);;
+(* Negation of monster_int (as a big_int) is not an int *)
+test 10
+eq (is_int_big_int
+     (minus_big_int (big_int_of_string (string_of_int monster_int))), false);;
+
+
+testing_function "sys_string_of_big_int";;
+
+test 1
+eq_string (string_of_big_int (big_int_of_int 1), "1");;
+
+
+testing_function "big_int_of_string";;
+
+test 1
+eq_big_int (big_int_of_string "1", big_int_of_int 1);;
+test 2
+eq_big_int (big_int_of_string "-1", big_int_of_int (-1));;
+test 4
+eq_big_int (big_int_of_string "0", zero_big_int);;
+
+failwith_test 5 big_int_of_string "sdjdkfighdgf"
+  (Failure "invalid digit");;
+
+test 6
+eq_big_int (big_int_of_string "123", big_int_of_int 123);;
+test 7
+eq_big_int (big_int_of_string "3456", big_int_of_int 3456);;
+
+test 9
+eq_big_int (big_int_of_string "-3456", big_int_of_int (-3456));;
+
+
+let implode = List.fold_left (^) "";; (* Au diable l'efficacite *)
+
+let l = rev [
+"174679877494298468451661416292903906557638850173895426081611831060970135303";
+"044177587617233125776581034213405720474892937404345377707655788096850784519";
+"539374048533324740018513057210881137248587265169064879918339714405948322501";
+"445922724181830422326068913963858377101914542266807281471620827145038901025";
+"322784396182858865537924078131032036927586614781817695777639491934361211399";
+"888524140253852859555118862284235219972858420374290985423899099648066366558";
+"238523612660414395240146528009203942793935957539186742012316630755300111472";
+"852707974927265572257203394961525316215198438466177260614187266288417996647";
+"132974072337956513457924431633191471716899014677585762010115338540738783163";
+"739223806648361958204720897858193606022290696766988489073354139289154127309";
+"916985231051926209439373780384293513938376175026016587144157313996556653811";
+"793187841050456120649717382553450099049321059330947779485538381272648295449";
+"847188233356805715432460040567660999184007627415398722991790542115164516290";
+"619821378529926683447345857832940144982437162642295073360087284113248737998";
+"046564369129742074737760485635495880623324782103052289938185453627547195245";
+"688272436219215066430533447287305048225780425168823659431607654712261368560";
+"702129351210471250717394128044019490336608558608922841794819375031757643448";
+"32"
+] in
+
+let bi1 = big_int_of_string (implode (rev l)) in
+
+let bi2 = big_int_of_string (implode (rev ("3" :: tl l))) in
+
+test 10
+eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10")) 
+                              (big_int_of_string "2")))
+(* test 11
+ &&
+eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10e0"))
+                              (big_int_of_string "20e-1"))) &&
+test 12
+eq_big_int (minus_big_int bi1,
+            (add_big_int (mult_big_int bi2 (big_int_of_string "-10e0"))
+                         (big_int_of_string "-20e-1"))) &&
+test 13
+eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "+10e0"))
+                              (big_int_of_string "+20e-1"))) &&
+test 14
+eq_big_int (minus_big_int bi1,
+            (add_big_int (mult_big_int bi2 (big_int_of_string "-10e+0"))
+                         (big_int_of_string "-20e-1"))) &&
+test 15
+eq_big_int (minus_big_int bi1,
+            (add_big_int (mult_big_int bi2 (big_int_of_string "-1e+1"))
+                         (big_int_of_string "-2e-0"))) &&
+test 16
+eq_big_int (minus_big_int bi1,
+            (add_big_int (mult_big_int bi2 (big_int_of_string "-0.1e+2"))
+                         (big_int_of_string "-2.0e-0"))) &&
+test 17
+eq_big_int (minus_big_int bi1,
+            (add_big_int (mult_big_int bi2 (big_int_of_string "-1.000e+1"))
+                         (big_int_of_string "-0.02e2")))*)
+;;
+
+testing_function "power_base_int";;
+
+test 1
+eq_big_int (big_int_of_nat (power_base_int 10 0), unit_big_int)
+;;
+test 2
+eq_big_int (big_int_of_nat (power_base_int 10 8), big_int_of_int 100000000)
+;;
+test 3
+eq_big_int (big_int_of_nat (power_base_int 2 (length_of_int + 2)), 
+            big_int_of_nat (let nat = make_nat 2 in
+                              set_digit_nat nat 1 1;
+                              nat))
+;;
+
+testing_function "base_power_big_int";;
+
+test 1
+eq_big_int (base_power_big_int 10 0 (big_int_of_int 2), big_int_of_int 2);;
+test 2
+eq_big_int (base_power_big_int 10 2 (big_int_of_int 2), big_int_of_int 200);;
+test 3
+eq_big_int (base_power_big_int 10 1 (big_int_of_int 123), big_int_of_int 1230)
+;;
+
+testing_function "power_int_positive_big_int";;
+
+test 1
+eq_big_int (power_int_positive_big_int 2 (big_int_of_int 10),
+            big_int_of_int 1024);;
+test 2
+eq_big_int
+ (power_int_positive_big_int 2 (big_int_of_int 65),
+  big_int_of_string "36893488147419103232");;
+
+test 3
+eq_big_int
+ (power_int_positive_big_int 3 (big_int_of_string "47"),
+  big_int_of_string "26588814358957503287787");;
+
+
+testing_function "power_big_int_positive_big_int";;
+
+test 1
+eq_big_int
+ (power_big_int_positive_big_int (big_int_of_int 2) (big_int_of_int 10),
+  big_int_of_int 1024);;
+
+test 2
+eq_big_int
+ (power_big_int_positive_big_int (big_int_of_int 2) (big_int_of_int 65),
+  big_int_of_string "36893488147419103232");;
+
+test 3
+eq_big_int
+ (power_big_int_positive_big_int
+   (big_int_of_string "3") (big_int_of_string "47"),
+  big_int_of_string "26588814358957503287787");;
+
+testing_function "square_big_int";;
+
+test 1 eq_big_int
+ (square_big_int (big_int_of_string "0"), big_int_of_string "0");;
+test 2 eq_big_int
+ (square_big_int (big_int_of_string "1"), big_int_of_string "1");;
+test 3 eq_big_int
+ (square_big_int (big_int_of_string "-1"), big_int_of_string "1");;
+test 4 eq_big_int
+ (square_big_int (big_int_of_string "-7"), big_int_of_string "49");;
diff --git a/otherlibs/num/test/test_bng.c b/otherlibs/num/test/test_bng.c
new file mode 100644
index 00000000..7679f093
--- /dev/null
+++ b/otherlibs/num/test/test_bng.c
@@ -0,0 +1,408 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2003 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../../LICENSE.  */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id: test_bng.c,v 1.2 2003/11/07 07:59:10 xleroy Exp $ */
+
+/* Test harness for the BNG primitives.  Use BigNum as a reference. */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <BigNum.h>
+
+#include "../../../config/m.h"
+#include "bng.h"
+
+#if defined(__GNUC__) && BNG_ASM_LEVEL > 0
+#if defined(BNG_ARCH_ia32)
+#include "bng_ia32.c"
+#elif defined(BNG_ARCH_amd64)
+#include "bng_amd64.c"
+#elif defined(BNG_ARCH_ppc)
+#include "bng_ppc.c"
+#elif defined (BNG_ARCH_alpha)
+#include "bng_alpha.c"
+#elif defined (BNG_ARCH_sparc)
+#include "bng_sparc.c"
+#elif defined (BNG_ARCH_mips)
+#include "bng_mips.c"
+#endif
+#endif
+
+#include "bng_digit.c"
+
+/* Random generator for digits.  Can either generate "true" PRN numbers
+   or numbers consisting of long sequences of 0 and 1 bits. */
+
+static int rand_skewed = 0;
+static int rand_runlength = 0;
+static int rand_bit = 0;
+static bngdigit rand_seed = 0;
+
+static bngdigit randdigit(void)
+{
+  bngdigit res;
+  int i;
+
+  if (rand_skewed) {
+    for (i = 0, res = 0; i < BNG_BITS_PER_DIGIT; i++) {
+      if (rand_runlength == 0) {
+        rand_runlength = 1 + (rand() % (2 * BNG_BITS_PER_DIGIT));
+        rand_bit ^= 1;
+      }
+      res = (res << 1) | rand_bit;
+      rand_runlength--;
+    }
+    return res;
+  } else {
+    rand_seed = rand_seed * 69069 + 25173;
+    return rand_seed;
+  }
+}
+
+/* Test the operations on digits.  
+   This uses double-width integer arithmetic as reference.
+   This is only available on 32-bit platforms that support a 64-bit int type.
+*/
+
+#if defined(ARCH_UINT64_TYPE) && !defined(ARCH_SIXTYFOUR)
+
+typedef ARCH_UINT64_TYPE dbldigit;
+
+static int test_digit_ops(int i)
+{
+  bngdigit a1, a2, a3, r1, r2;
+  int ci, co, n;
+
+  a1 = randdigit();
+  a2 = randdigit();
+  a3 = randdigit();
+  ci = randdigit() & 1;
+
+  BngAdd2(r1,co,a1,a2);
+  if ((dbldigit) r1 + ((dbldigit) co << BNG_BITS_PER_DIGIT)
+      != (dbldigit) a1 + (dbldigit) a2) {
+    printf("Round %d, BngAdd2(%lx,%x,%lx, %lx)\n", i, r1, co, a1, a2);
+    return 1;
+  }
+
+  BngAdd2Carry(r1,co,a1,a2,ci);
+  if ((dbldigit) r1 + ((dbldigit) co << BNG_BITS_PER_DIGIT)
+      != (dbldigit) a1 + (dbldigit) a2 + (dbldigit) ci) {
+    printf("Round %d, BngAdd2Carry(%lx,%x,%lx, %lx, %x)\n", i, r1, co, a1, a2, ci);
+    return 1;
+  }
+
+  r2 = 0;
+  BngAdd3(r1,r2,a1,a2,a3);
+  if ((dbldigit) r1 + ((dbldigit) r2 << BNG_BITS_PER_DIGIT)
+      != (dbldigit) a1 + (dbldigit) a2 + (dbldigit) a3) {
+    printf("Round %d, BngAdd3(%lx,%x,%lx, %lx, %lx)\n", i, r1, co, a1, a2, a3);
+    return 1;
+  }
+
+  BngSub2(r1,co,a1,a2);
+  if ((dbldigit) r1 - ((dbldigit) co << BNG_BITS_PER_DIGIT)
+      != (dbldigit) a1 - (dbldigit) a2) {
+    printf("Round %d, BngSub2(%lx,%x,%lx, %lx)\n", i, r1, co, a1, a2);
+    return 1;
+  }
+
+  BngSub2Carry(r1,co,a1,a2,ci);
+  if ((dbldigit) r1 - ((dbldigit) co << BNG_BITS_PER_DIGIT)
+      != (dbldigit) a1 - (dbldigit) a2 - (dbldigit) ci) {
+    printf("Round %d, BngSub2Carry(%lx,%x,%lx, %lx, %x)\n", i, r1, co, a1, a2, ci);
+    return 1;
+  }
+
+  r2 = 0;
+  BngSub3(r1,r2,a1,a2,a3);
+  if ((dbldigit) r1 - ((dbldigit) r2 << BNG_BITS_PER_DIGIT)
+      != (dbldigit) a1 - (dbldigit) a2 - (dbldigit) a3) {
+    printf("Round %d, BngSub3(%lx,%x,%lx, %lx, %lx)\n", i, r1, co, a1, a2, a3);
+    return 1;
+  }
+
+  BngMult(r1,r2,a1,a2);
+  if ((((dbldigit) r1 << BNG_BITS_PER_DIGIT) | (dbldigit) r2)
+      != (dbldigit) a1 * (dbldigit) a2) {
+    printf("Round %d, BngMult(%lx,%lx,%lx, %lx)\n", i, r1, r2, a1, a2);
+    return 1;
+  }
+
+  /* Make sure a3 is normalized */
+  a3 |= 1L << (BNG_BITS_PER_DIGIT - 1);
+  if (a1 < a3) {
+    BngDiv(r1,r2,a1,a2,a3);
+    if (r1 != (((dbldigit) a1 << BNG_BITS_PER_DIGIT) | (dbldigit) a2) / a3
+        ||
+        r2 != (((dbldigit) a1 << BNG_BITS_PER_DIGIT) | (dbldigit) a2) % a3)
+      {
+        printf("Round %d, BngDiv(%lx,%lx,%lx, %lx, %lx)\n", i, r1, r2, a1, a2, a3);
+        return 1;
+      }
+  }
+
+  n = bng_leading_zero_bits(a1);
+  if (a1 == 0) {
+    if (n != BNG_BITS_PER_DIGIT) {
+      printf("Round %d, bng_leading_zero(bits(%lx) = %d", i, a1, n);
+      return 1;
+    }
+  } else {
+    if ((a1 << n) >> n != a1 ||
+        ((a1 << n) & (1L << (BNG_BITS_PER_DIGIT - 1))) == 0) {
+      printf("Round %d, bng_leading_zero(bits(%lx) = %d", i, a1, n);
+      return 1;
+    }
+  }
+  return 0;
+}
+
+#endif
+
+/* Test the bng operations.  Use BigNum as a reference. */
+
+#define MAX_DIGITS 32
+
+void randbng(bng a, bngsize n)
+{
+  int i;
+  for (i = 0; i < n; i++) a[i] = randdigit();
+}
+
+char * bng2string(bng a, bngsize n)
+{
+  char * buffer = malloc((BNG_BITS_PER_DIGIT / 4 + 1) * MAX_DIGITS);
+  char temp[BNG_BITS_PER_DIGIT / 4 + 1];
+  int i;
+
+  buffer[0] = 0;
+  for (i = n - 1; i >= 0; i--) {
+    sprintf(temp, "%lx", a[i]);
+    strcat(buffer, temp);
+    if (i > 0) strcat(buffer, "_");
+  }
+  return buffer;
+}
+
+int bngsame(bng a, bng b, bngsize n)
+{
+  int i;
+  for (i = 0; i < n; i++)
+    if (a[i] != b[i]) return 0;
+  return 1;
+}
+
+int test_bng_ops(int i)
+{
+  bngsize p, q;
+  bngdigit a[MAX_DIGITS], b[MAX_DIGITS], c[MAX_DIGITS], d[MAX_DIGITS];
+  bngdigit f[2 * MAX_DIGITS], g[2 * MAX_DIGITS], h[2 * MAX_DIGITS];
+  bngcarry ci, co, cp;
+  bngdigit dg, do_, dp;
+  int amount;
+
+  /* Determine random lengths p and q between 1 and MAX_DIGITS.
+     Ensure p >= q. */
+  p = 1 + (rand() % MAX_DIGITS);
+  q = 1 + (rand() % MAX_DIGITS);
+  if (q > p) { bngsize t = p; p = q; q = t; }
+
+  /* Randomly generate bignums a of size p, b of size q */
+  randbng(a, p);
+  randbng(b, q);
+  ci = rand() & 1;
+
+  /* comparison */
+  co = bng_compare(a, p, b, q);
+  cp = BnnCompare(a, p, b, q);
+  if (co != cp) {
+    printf("Round %d, bng_compare(%s, %ld, %s, %ld) = %d\n",
+           i, bng2string(a, p), p, bng2string(b, q), q, co);
+    return 1;
+  }
+  co = bng_compare(b, q, a, p);
+  cp = BnnCompare(b, q, a, p);
+  if (co != cp) {
+    printf("Round %d, bng_compare(%s, %ld, %s, %ld) = %d\n",
+           i, bng2string(b, q), q, bng2string(a, p), p, co);
+    return 1;
+  }
+  /* add carry */
+  bng_assign(c, a, p);
+  co = bng_add_carry(c, p, ci);
+  BnnAssign(d, a, p);
+  cp = BnnAddCarry(d, p, ci);
+  if (co != cp || !bngsame(c, d, p)) {
+    printf("Round %d, bng_add_carry(%s, %ld, %d) -> %s, %d\n",
+           i, bng2string(a, p), p, ci, bng2string(c, p), co);
+    return 1;
+  }
+  /* add */
+  bng_assign(c, a, p);
+  co = bng_add(c, p, b, q, ci);
+  BnnAssign(d, a, p);
+  cp = BnnAdd(d, p, b, q, ci);
+  if (co != cp || !bngsame(c, d, p)) {
+    printf("Round %d, bng_add(%s, %ld, %s, %ld, %d) -> %s, %d\n",
+           i, bng2string(a, p), p, bng2string(b, q), q, ci,
+           bng2string(c, p), co);
+    return 1;
+  }
+  /* sub carry */
+  bng_assign(c, a, p);
+  co = bng_sub_carry(c, p, ci);
+  BnnAssign(d, a, p);
+  cp = BnnSubtractBorrow(d, p, ci ^ 1) ^ 1;
+  if (co != cp || !bngsame(c, d, p)) {
+    printf("Round %d, bng_sub_carry(%s, %ld, %d) -> %s, %d\n",
+           i, bng2string(a, p), p, ci, bng2string(c, p), co);
+    return 1;
+  }
+  /* sub */
+  bng_assign(c, a, p);
+  co = bng_sub(c, p, b, q, ci);
+  BnnAssign(d, a, p);
+  cp = BnnSubtract(d, p, b, q, ci ^ 1) ^ 1;
+  if (co != cp || !bngsame(c, d, p)) {
+    printf("Round %d, bng_sub(%s, %ld, %s, %ld, %d) -> %s, %d\n",
+           i, bng2string(a, p), p, bng2string(b, q), q, ci,
+           bng2string(c, p), co);
+    return 1;
+  }
+  /* shift left */
+  amount = rand() % BNG_BITS_PER_DIGIT;
+  bng_assign(c, a, p);
+  do_ = bng_shift_left(c, p, amount);
+  BnnAssign(d, a, p);
+  dp = BnnShiftLeft(d, p, amount);
+  if (do_ != dp || !bngsame(c, d, p)) {
+    printf("Round %d, bng_shift_left(%s, %ld, %d) -> %s, %ld\n",
+           i, bng2string(a, p), p, amount, bng2string(c, p), do_);
+    return 1;
+  }
+  /* shift right */
+  amount = rand() % BNG_BITS_PER_DIGIT;
+  bng_assign(c, a, p);
+  do_ = bng_shift_right(c, p, amount);
+  BnnAssign(d, a, p);
+  dp = BnnShiftRight(d, p, amount);
+  if (do_ != dp || !bngsame(c, d, p)) {
+    printf("Round %d, bng_shift_right(%s, %ld, %d) -> %s, %ld\n",
+           i, bng2string(a, p), p, amount, bng2string(c, p), do_);
+    return 1;
+  }
+  /* mult_add_digit */
+  dg = randdigit();
+  if (p >= q + 1) {
+    bng_assign(c, a, p);
+    co = bng_mult_add_digit(c, p, b, q, dg);
+    BnnAssign(d, a, p);
+    cp = BnnMultiplyDigit(d, p, b, q, dg);
+    if (co != cp || !bngsame(c, d, p)) {
+      printf("Round %d, bng_mult_add_digit(%s, %ld, %s, %ld, %ld) -> %s, %d\n",
+             i, bng2string(a, p), p, bng2string(b, q), q, dg,
+             bng2string(c, p), co);
+      return 1;
+    }
+  }
+  /* mult_sub_digit */
+  dg = randdigit();
+  bng_assign(c, a, p);
+  do_ = bng_mult_add_digit(c, p, b, q, dg);
+  bng_assign(d, c, p);
+  dp = bng_mult_sub_digit(d, p, b, q, dg);
+  if (do_ != dp || !bngsame(a, d, p)) {
+    printf("Round %d, bng_mult_sub_digit(%s, %ld, %s, %ld, %ld) -> %s, %ld\n",
+           i, bng2string(c, p), p, bng2string(b, q), q, dg,
+           bng2string(d, p), dp);
+    return 1;
+  }
+  /* mult_add */
+  randbng(f, 2*p);
+  bng_assign(g, f, 2*p);
+  co = bng_mult_add(g, 2*p, a, p, b, q);
+  BnnAssign(h, f, 2*p);
+  cp = BnnMultiply(h, 2*p, a, p, b, q);
+  if (co != cp || !bngsame(g, h, 2*p)) {
+    printf("Round %d, bng_mult_add(%s, %ld, %s, %ld, %s, %ld) -> %s, %d\n",
+           i, bng2string(f, 2*p), 2*p,
+           bng2string(a, p), p,
+           bng2string(b, q), q,
+           bng2string(g, 2*p), co);
+    return 1;
+  }
+  /* square_add */
+  randbng(f, 2*p);
+  bng_assign(g, f, 2*p);
+  co = bng_square_add(g, 2*p, b, q);
+  BnnAssign(h, f, 2*p);
+  cp = BnnAdd(h, 2*p, h, 2*p);
+  cp += BnnMultiply(h, 2*p, b, q, b, q);
+  if (co != cp || !bngsame(g, h, 2*p)) {
+    printf("Round %d, bng_square_add(%s, %ld, %s, %ld) -> %s, %d\n",
+           i, bng2string(f, 2*p), 2*p,
+           bng2string(b, q), q,
+           bng2string(g, 2*p), co);
+    return 1;
+  }
+  /* div_rem_digit */
+  if (a[p - 1] < dg) {
+    do_ = bng_div_rem_digit(c, a, p, dg);
+    dp = BnnDivideDigit(d, a, p, dg);
+    if (do_ != dp || !bngsame(c, d, p-1)) {
+      printf("Round %d, bng_div_rem_digit(%s, %s, %ld, %lx) -> %lx\n",
+             i, bng2string(d, p-1), bng2string(a, p), p, dg, do_);
+      return 1;
+    }
+  }
+  /* div_rem */
+  if (p > q && a[p - 1] < b[q - 1]) {
+    bng_assign(c, a, p);
+    bng_div_rem(c, p, b, q);
+    BnnAssign(d, a, p);
+    BnnDivide(d, p, b, q);
+    if (!bngsame(c, d, p)) {
+      printf("Round %d, bng_div_rem(%s, %ld, %s, %ld) -> %s, %s\n",
+             i, bng2string(a, p), p, bng2string(b, q), q,
+             bng2string(c + q, p - q),
+             bng2string(c, q));
+      return 1;
+    }
+  }
+  return 0;
+}
+
+int main(int argc, char ** argv)
+{
+  int niter = 100000;
+  int i, err;
+
+  bng_init();
+  if (argc >= 2) niter = atoi(argv[1]);
+#if defined(ARCH_UINT64_TYPE) && !defined(ARCH_SIXTYFOUR)
+  printf("Testing single-digit operations\n");
+  for (err = 0, i = 1; i < niter; i++) err += test_digit_ops(i);
+  printf("%d rounds performed, %d errors found\n", niter, err);
+#endif
+  printf("Testing bignum operations\n");
+  for (err = 0, i = 1; i < niter; i++) err += test_bng_ops(i);
+  printf("%d rounds performed, %d errors found\n", niter, err);
+  printf("Testing bignum operations with skewed PRNG\n");
+  rand_skewed = 1;
+  for (err = 0, i = 1; i < niter; i++) err += test_bng_ops(i);
+  printf("%d rounds performed, %d errors found\n", niter, err);
+  return 0;
+}
diff --git a/otherlibs/num/test/test_io.ml b/otherlibs/num/test/test_io.ml
new file mode 100644
index 00000000..1df11a5f
--- /dev/null
+++ b/otherlibs/num/test/test_io.ml
@@ -0,0 +1,64 @@
+open Test
+open Nat
+open Big_int
+open Num
+
+let intern_extern obj =
+  let f = Filename.temp_file "testnum" ".data" in
+  let oc = open_out_bin f in
+  output_value oc obj;
+  close_out oc;
+  let ic = open_in_bin f in
+  let res = input_value ic in
+  close_in ic;
+  Sys.remove f;
+  res
+;;
+
+testing_function "output_value/input_value on nats";;
+
+let equal_nat n1 n2 =
+  eq_nat n1 0 (length_nat n1) n2 0 (length_nat n2)
+;;
+
+List.iter
+  (fun (i, s) ->
+    let n = nat_of_string s in
+    ignore(test i equal_nat (n, intern_extern n)))
+  [1, "0";
+   2, "1234";
+   3, "8589934592";
+   4, "340282366920938463463374607431768211455";
+   5, String.make 100 '3';
+   6, String.make 1000 '9';
+   7, String.make 20000 '8']
+;;
+
+testing_function "output_value/input_value on big ints";;
+
+List.iter
+  (fun (i, s) ->
+    let b = big_int_of_string s in
+    ignore(test i eq_big_int (b, intern_extern b)))
+  [1, "0";
+   2, "1234";
+   3, "-1234";
+   4, "1040259735709286400";
+   5, "-" ^ String.make 20000 '7']
+;;
+
+testing_function "output_value/input_value on nums";;
+
+List.iter
+  (fun (i, s) ->
+    let n = num_of_string s in
+    ignore(test i eq_num (n, intern_extern n)))
+  [1, "0";
+   2, "1234";
+   3, "-1234";
+   4, "159873568791325097646845892426782";
+   5, "1/4";
+   6, "-15/2";
+   7, "159873568791325097646845892426782/24098772507410987265987";
+   8, String.make 10000 '3' ^ "/" ^ String.make 5000 '7']
+;;
diff --git a/otherlibs/num/test/test_nats.ml b/otherlibs/num/test/test_nats.ml
new file mode 100644
index 00000000..bfb26f10
--- /dev/null
+++ b/otherlibs/num/test/test_nats.ml
@@ -0,0 +1,142 @@
+open Test;;
+open Nat;;
+
+(* Can compare nats less than 2**32 *)
+let equal_nat n1 n2 =
+ eq_nat n1 0 (num_digits_nat n1 0 1) 
+        n2 0 (num_digits_nat n2 0 1);;
+
+testing_function "num_digits_nat";;
+
+test (-1) eq (false,not true);;
+test 0 eq (true,not false);;
+
+test 1
+eq_int
+(let r = make_nat 2 in
+  set_digit_nat r 1 1;
+  num_digits_nat r 0 1,1);;
+
+testing_function "length_nat";;
+
+test 1
+eq_int
+(let r = make_nat 2 in
+  set_digit_nat r 0 1;
+  length_nat r,2);;
+
+testing_function "equal_nat";;
+
+let zero_nat = make_nat 1 in
+
+test 1
+equal_nat (zero_nat,zero_nat);;
+test 2
+equal_nat (nat_of_int 1,nat_of_int 1);;
+
+test 3
+equal_nat (nat_of_string "2",nat_of_string "2");;
+test 4
+eq (equal_nat (nat_of_string "2")(nat_of_string "3"),false);;
+
+testing_function "incr_nat";;
+
+let zero = nat_of_int 0 in
+let res = incr_nat zero 0 1 1 in
+ test 1
+  equal_nat (zero, nat_of_int 1) &&
+ test 2
+  eq (res,0);;
+
+let n = nat_of_int 1 in
+let res = incr_nat n 0 1 1 in
+ test 3
+  equal_nat (n, nat_of_int 2) &&
+ test 4
+  eq (res,0);;
+
+
+testing_function "decr_nat";;
+
+let n = nat_of_int 1 in
+let res = decr_nat n 0 1 0 in
+ test 1
+  equal_nat (n, nat_of_int 0) &&
+ test 2
+  eq (res,1);;
+
+let n = nat_of_int 2 in
+let res = decr_nat n 0 1 0 in
+ test 3
+  equal_nat (n, nat_of_int 1) &&
+ test 4
+  eq (res,1);;
+
+testing_function "is_zero_nat";;
+
+let n = nat_of_int 1 in
+test 1 eq (is_zero_nat n 0 1,false) &&
+test 2 eq (is_zero_nat (make_nat 1) 0 1, true) &&
+test 3 eq (is_zero_nat (make_nat 2) 0 2, true) &&
+(let r = make_nat 2 in
+  set_digit_nat r 1 1;
+  test 4 eq (is_zero_nat r 0 1, true))
+;;
+
+testing_function "string_of_nat";;
+
+let n = make_nat 4;;
+
+test 1 eq_string (string_of_nat n, "0");;
+
+complement_nat n 0 (if sixtyfour then 2 else 4);;
+
+test 2 eq_string (string_of_nat n, "340282366920938463463374607431768211455");;
+
+testing_function "string_of_nat && nat_of_string";;
+
+for i = 1 to 20 do
+  let s = String.make i '0' in
+    String.set s 0 '1';
+    test i eq_string (string_of_nat (nat_of_string s), s)
+done;;
+
+let s = "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333" in
+test 21 equal_nat (
+nat_of_string s,
+(let nat = make_nat 15 in 
+  set_digit_nat nat 0 3;
+  mult_digit_nat nat 0 15 
+                 (nat_of_string (String.sub s 0 135)) 0 14 
+                 (nat_of_int 10) 0;
+  nat))
+;;
+
+test 22 eq_string (string_of_nat(nat_of_string "1073741824"), "1073741824");;
+
+testing_function "gcd_nat";;
+
+for i = 1 to 20 do
+  let n1 = Random.int 1000000000
+  and n2 = Random.int 100000 in
+  let nat1 = nat_of_int n1
+  and nat2 = nat_of_int n2 in
+  gcd_nat nat1 0 1 nat2 0 1;
+    test i eq (int_of_nat nat1, Int_misc.gcd_int n1 n2)
+done
+;;
+
+testing_function "sqrt_nat";;
+
+test 1 equal_nat (sqrt_nat (nat_of_int 1) 0 1, nat_of_int 1);;
+test 2 equal_nat (let n = nat_of_string "8589934592" in
+                  sqrt_nat n 0 (length_nat n),
+                  nat_of_string "92681");;
+test 3 equal_nat (let n = nat_of_string "4294967295" in
+                  sqrt_nat n 0 (length_nat n),
+                  nat_of_string "65535");;
+test 4 equal_nat (let n = nat_of_string "18446744065119617025" in
+                  sqrt_nat n 0 (length_nat n),
+                  nat_of_string "4294967295");;
+test 5 equal_nat (sqrt_nat (nat_of_int 15) 0 1,
+                  nat_of_int 3);;
diff --git a/otherlibs/num/test/test_nums.ml b/otherlibs/num/test/test_nums.ml
new file mode 100644
index 00000000..42428580
--- /dev/null
+++ b/otherlibs/num/test/test_nums.ml
@@ -0,0 +1,220 @@
+open Test;;
+open Nat;;
+open Big_int;;
+open Ratio;;
+open Int_misc;;
+open Num;;
+open Arith_status;;
+
+testing_function "add_num";;
+
+test 1
+eq_num (add_num (Int 1) (Int 3), Int 4);;
+test 2
+eq_num (add_num (Int 1) (Big_int (big_int_of_int 3)), Int 4);;
+test 3
+eq_num (add_num (Int 1) (Ratio (ratio_of_string "3/4")), 
+        Ratio (ratio_of_string "7/4"));;
+test 4
+eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), 
+        Ratio (ratio_of_string "7/4"));;
+test 5
+eq_num (add_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)),
+        Int 4);;
+test 6
+eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")),
+        Ratio (ratio_of_string "7/4"));;
+test 7
+eq_num (add_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")),
+        Ratio (ratio_of_string "17/12"));;
+test 8
+eq_num (add_num (Int least_int) (Int 1), 
+        Int (- (pred biggest_int)));;
+test 9
+eq_num (add_num (Int biggest_int) (Int 1), 
+        Big_int (minus_big_int (pred_big_int (big_int_of_int least_int))));;
+
+testing_function "sub_num";;
+
+test 1
+eq_num (sub_num (Int 1) (Int 3), Int (-2));;
+test 2
+eq_num (sub_num (Int 1) (Big_int (big_int_of_int 3)), Int (-2));;
+test 3
+eq_num (sub_num (Int 1) (Ratio (ratio_of_string "3/4")), 
+        Ratio (ratio_of_string "1/4"));;
+test 4
+eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), 
+        Ratio (ratio_of_string "1/4"));;
+test 5
+eq_num (sub_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)),
+        Int (-2));;
+test 7
+eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")),
+        Ratio (ratio_of_string "1/4"));;
+test 8
+eq_num (sub_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")),
+        Ratio (ratio_of_string "-1/12"));;
+test 9
+eq_num (sub_num (Int least_int) (Int (-1)), 
+        Int (- (pred biggest_int)));;
+test 10
+eq_num (sub_num (Int (-1)) (Int biggest_int), pred_num (Int least_int));;
+
+testing_function "mult_num";;
+
+test 1
+eq_num (mult_num (Int 2) (Int 3), Int 6);;
+test 2
+eq_num (mult_num (Int 127) (Int (int_of_string "257")),
+                  Int (int_of_string "32639"));;
+test 3
+eq_num (mult_num (Int 257) (Int (int_of_string "260")), 
+        Big_int (big_int_of_string "66820"));;
+test 4
+eq_num (mult_num (Int 2) (Big_int (big_int_of_int 3)), Int 6);;
+test 5
+eq_num (mult_num (Int 10) (Ratio (ratio_of_string "3/4")), 
+        Ratio (ratio_of_string "15/2"));;
+test 6
+eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")),
+        Ratio (ratio_of_string "15/2"));;
+test 7
+eq_num (mult_num (Big_int (big_int_of_int 2)) (Big_int (big_int_of_int 3)),
+        Int 6);;
+test 8
+eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")),
+        Ratio (ratio_of_string "15/2"));;
+test 9
+eq_num (mult_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4"))
+               , Ratio (ratio_of_string "1/2"));;
+
+testing_function "div_num";;
+
+test 1
+eq_num (div_num (Int 6) (Int 3), Int 2);;
+test 2
+eq_num (div_num (Int (int_of_string "32639")) 
+                 (Int (int_of_string "257")), Int 127);;
+test 3
+eq_num (div_num (Big_int (big_int_of_string "66820")) 
+                 (Int (int_of_string "257")), 
+        Int 260);;
+test 4
+eq_num (div_num (Int 6) (Big_int (big_int_of_int 3)), Int 2);;
+test 5
+eq_num (div_num (Ratio (ratio_of_string "15/2")) 
+                 (Int 10),
+        Ratio (ratio_of_string "3/4"));; 
+test 6
+eq_num (div_num (Big_int (big_int_of_int 6)) (Big_int (big_int_of_int 3)),
+        Int 2);;
+test 7 
+eq_num (div_num (Ratio (ratio_of_string "15/2")) 
+                 (Big_int (big_int_of_int 10)),
+        Ratio (ratio_of_string "3/4"));;
+test 8
+eq_num (div_num (Ratio (ratio_of_string "15/2")) 
+                 (Ratio (ratio_of_string "3/4")),
+        Big_int (big_int_of_int 10));;
+test 9
+eq_num (div_num (Ratio (ratio_of_string "1/2")) 
+                 (Ratio (ratio_of_string "3/4")),
+        Ratio (ratio_of_string "2/3"));;
+
+testing_function "is_integer_num";;
+
+test 1
+eq (is_integer_num (Int 3),true);;
+test 2
+eq (is_integer_num (Big_int (big_int_of_string "1234567890")),true);;
+test 3
+eq (not (is_integer_num (Ratio (ratio_of_string "1/2"))),true);;
+test 4
+eq (is_integer_num (Ratio (ratio_of_string "1073774590/32770")),true);;
+
+testing_function "num_of_ratio";;
+
+test 1
+eq_num (num_of_ratio (ratio_of_string "4/2"), Int 2);;
+test 2
+eq_num (num_of_ratio (ratio_of_string "11811160075/11"), 
+        Big_int (big_int_of_string "1073741825"));;
+test 3
+eq_num (num_of_ratio (ratio_of_string "123456789012/1234"),
+        Ratio (ratio_of_string "61728394506/617"));;
+
+testing_function "num_of_string";;
+
+test 1
+eq_num (num_of_string "123/3456", Ratio (ratio_of_string "123/3456"));;
+(*********
+test 2
+eq_num (num_of_string "12.3/34.56", Ratio (ratio_of_string "1230/3456"));;
+test 3
+eq_num (num_of_string "1.23/325.6", Ratio (ratio_of_string "123/32560"));;
+test 4
+eq_num (num_of_string "12.3/345.6", Ratio (ratio_of_string "123/3456"));;
+set_error_when_null_denominator false;;
+test 5
+eq_num (num_of_string "12.3/0.0", Ratio (ratio_of_string "123/0"));;
+test 6
+eq_num (num_of_string "0/0", Ratio (ratio_of_string "0/0"));;
+set_error_when_null_denominator true;;
+*********)
+test 7
+eq_num (num_of_string "1234567890",
+        Big_int (big_int_of_string "1234567890"));;
+test 8
+eq_num (num_of_string "12345", Int (int_of_string "12345"));;
+(*********
+test 9
+eq_num (num_of_string "0.23", Ratio (ratio_of_string "23/100"));;
+test 10
+eq_num (num_of_string "0.23", Ratio (ratio_of_string "0.23/1"));;
+********)
+
+failwith_test 11
+num_of_string ("frlshjkurty") (Failure "num_of_string");;
+
+(*******
+
+testing_function "immediate numbers";;
+
+standard arith false;;
+
+let x = (1/2) in
+test 0 eq_string (string_of_num x, "1/2");;
+
+let y = 12345678901 in
+test 1 eq_string (string_of_num y, "12345678901");;
+testing_function "immediate numbers";;
+
+let x = (1/2) in
+test 0 eq_string (string_of_num x, "1/2");;
+
+let y = 12345678901 in
+test 1 eq_string (string_of_num y, "12345678901");;
+
+testing_function "pattern_matching on nums";;
+
+let f1 = function 0 -> true | _  -> false;;
+
+test 1 eq (f1 0, true);;
+
+test 2 eq (f1 1, false);;
+
+test 3 eq (f1 (0/1), true);;
+
+test 4 eq (f1 (let n = num_of_string "2000000000000000000000000" in n-n) , 
+            true);;
+
+test 5 eq (f1 (let n = num_of_string "2000000000000000000000000" in n/n-1) , 
+            true);;
+
+test 6 eq (f1 (let n = num_of_string "2000000000000000000000000" in n+1) , 
+            false);;
+
+test 7 eq (f1 (1/2), false);;
+
+**************)
diff --git a/otherlibs/num/test/test_ratios.ml b/otherlibs/num/test/test_ratios.ml
new file mode 100644
index 00000000..45fdce8b
--- /dev/null
+++ b/otherlibs/num/test/test_ratios.ml
@@ -0,0 +1,928 @@
+open Test;;
+open Nat;;
+open Big_int;;
+open Ratio;;
+open Int_misc;;
+open Arith_status;;
+
+set_error_when_null_denominator false;;
+
+let infinite_failure = "infinite or undefined rational number";;
+
+testing_function "create_ratio";;
+
+let r = create_ratio (big_int_of_int 1) (big_int_of_int (-2)) in
+test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && 
+test 2 eq_big_int (denominator_ratio r, big_int_of_int 2);;
+
+let r = create_ratio (big_int_of_int 2) (big_int_of_int 3) in
+test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) && 
+test 4 eq_big_int (denominator_ratio r, big_int_of_int 3);;
+
+set_normalize_ratio true;;
+
+let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in
+test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && 
+test 6 eq_big_int (denominator_ratio r, big_int_of_int 4);;
+
+set_normalize_ratio false;;
+
+let r = create_ratio (big_int_of_int 0) (big_int_of_int 0) in
+test 7 eq_big_int (numerator_ratio r, big_int_of_int 0) && 
+test 8 eq_big_int (denominator_ratio r, big_int_of_int 0);;
+
+testing_function "create_normalized_ratio";;
+
+let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int (-2)) in
+test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && 
+test 2 eq_big_int (denominator_ratio r, big_int_of_int 2);;
+
+let r = create_normalized_ratio (big_int_of_int 2) (big_int_of_int 3) in
+test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) && 
+test 4 eq_big_int (denominator_ratio r, big_int_of_int 3);;
+
+set_normalize_ratio true;;
+
+let r = create_normalized_ratio (big_int_of_int 12) (big_int_of_int (-16)) in
+test 5 eq_big_int (numerator_ratio r, big_int_of_int (-12)) && 
+test 6 eq_big_int (denominator_ratio r, big_int_of_int 16);;
+
+set_normalize_ratio false;;
+
+let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int 0) in
+test 7 eq_big_int (numerator_ratio r, big_int_of_int 1) && 
+test 8 eq_big_int (denominator_ratio r, big_int_of_int 0);;
+
+let r = create_normalized_ratio (big_int_of_int 0) (big_int_of_int 0) in
+test 9 eq_big_int (numerator_ratio r, big_int_of_int 0) && 
+test 10 eq_big_int (denominator_ratio r, big_int_of_int 0);;
+
+testing_function "null_denominator";;
+
+test 1
+ eq (null_denominator (create_ratio (big_int_of_int 1) (big_int_of_int (-2))),
+     false);;
+test 2 eq
+ (null_denominator (create_ratio (big_int_of_int 1) zero_big_int),true);;
+
+(*****
+testing_function "verify_null_denominator";;
+
+test 1
+ eq (verify_null_denominator (ratio_of_string "0/1"), false);;
+test 2
+ eq (verify_null_denominator (ratio_of_string "0/0"), true);;
+*****)
+
+testing_function "sign_ratio";;
+
+test 1
+eq_int (sign_ratio (create_ratio (big_int_of_int (-2)) (big_int_of_int (-3))), 
+        1);;
+test 2
+eq_int (sign_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-3))), 
+        (-1));;
+test 3
+eq_int (sign_ratio (create_ratio zero_big_int (big_int_of_int (-3))), 0);;
+
+testing_function "normalize_ratio";;
+
+let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in
+normalize_ratio r;
+test 1 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && 
+test 2 eq_big_int (denominator_ratio r, big_int_of_int 4);;
+
+let r = create_ratio (big_int_of_int (-1)) zero_big_int in
+normalize_ratio r;
+test 3 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && 
+test 4 eq_big_int (denominator_ratio r, zero_big_int);;
+
+testing_function "report_sign_ratio";;
+
+test 1 
+eq_big_int (report_sign_ratio 
+            (create_ratio (big_int_of_int 2) (big_int_of_int (-3))) 
+            (big_int_of_int 1),
+            big_int_of_int (-1));;
+test 2
+eq_big_int (report_sign_ratio 
+            (create_ratio (big_int_of_int 2) (big_int_of_int 3)) 
+             (big_int_of_int 1),
+            big_int_of_int 1);;
+
+testing_function "is_integer_ratio";;
+
+test 1 eq
+ (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-1))),
+  true);;
+test 2 eq
+ (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)),
+  false);;
+
+testing_function "add_ratio";;
+
+let r = add_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)) 
+                   (create_ratio (big_int_of_int 2) (big_int_of_int 3)) in
+test 1 eq_big_int (numerator_ratio r, big_int_of_int 7) && 
+test 2 eq_big_int (denominator_ratio r, big_int_of_int 6);;
+
+let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) 
+                   (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
+test 3 eq_big_int (numerator_ratio r, big_int_of_int 1) && 
+test 4 eq_big_int (denominator_ratio r, big_int_of_int 6);;
+
+let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int) 
+                   (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
+test 5 eq_big_int (numerator_ratio r, big_int_of_int 4) && 
+test 6 eq_big_int (denominator_ratio r, zero_big_int);;
+
+let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) 
+                   (create_ratio (big_int_of_int 1) zero_big_int) in
+test 7 eq_big_int (numerator_ratio r, big_int_of_int 3) && 
+test 8 eq_big_int (denominator_ratio r, zero_big_int);;
+
+let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int) 
+                   (create_ratio (big_int_of_int 1) zero_big_int) in
+test 9 eq_big_int (numerator_ratio r, zero_big_int) && 
+test 10 eq_big_int (denominator_ratio r, zero_big_int);;
+
+let r = add_ratio (create_ratio (big_int_of_string "12724951") 
+                                 (big_int_of_string "26542080")) 
+                   (create_ratio (big_int_of_string "-1") 
+                                 (big_int_of_string "81749606400")) in
+test 11 eq_big_int (numerator_ratio r, 
+                     big_int_of_string "1040259735682744320") && 
+test 12 eq_big_int (denominator_ratio r, 
+                     big_int_of_string "2169804593037312000");;
+
+let r1,r2 =
+ (create_ratio (big_int_of_string "12724951") 
+                                 (big_int_of_string "26542080"), 
+                   create_ratio (big_int_of_string "-1") 
+                                 (big_int_of_string "81749606400")) in
+
+let bi1 = mult_big_int (numerator_ratio r1) (denominator_ratio r2)
+and  bi2 = mult_big_int (numerator_ratio r2) (denominator_ratio r1) 
+in
+test 1
+eq_big_int (bi1,
+            big_int_of_string "1040259735709286400")
+&& 
+test 2
+eq_big_int (bi2,
+            big_int_of_string "-26542080")
+&& test 3
+eq_big_int (mult_big_int (denominator_ratio r1) (denominator_ratio r2),
+            big_int_of_string "2169804593037312000")
+&& test 4
+eq_big_int (add_big_int bi1 bi2,
+            big_int_of_string "1040259735682744320")
+;;
+
+testing_function "sub_ratio";;
+
+let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) 
+                   (create_ratio (big_int_of_int 1) (big_int_of_int 2)) in
+test 1  eq_big_int (numerator_ratio r, big_int_of_int 1) && 
+test 2 eq_big_int (denominator_ratio r, big_int_of_int 6);;
+
+let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int) 
+                   (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
+test 3 eq_big_int (numerator_ratio r, big_int_of_int 4) && 
+test 4 eq_big_int (denominator_ratio r, zero_big_int);;
+
+let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) 
+                   (create_ratio (big_int_of_int 1) zero_big_int) in
+test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && 
+test 6 eq_big_int (denominator_ratio r, zero_big_int);;
+
+let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int) 
+                   (create_ratio (big_int_of_int 1) zero_big_int) in
+test 7 eq_big_int (numerator_ratio r, zero_big_int) && 
+test 8 eq_big_int (denominator_ratio r, zero_big_int);;
+
+testing_function "mult_ratio";;
+
+let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) 
+                    (create_ratio (big_int_of_int 7) (big_int_of_int 5)) in
+test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) && 
+test 2 eq_big_int (denominator_ratio r, big_int_of_int 15);;
+
+let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int) 
+                    (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
+test 3 eq_big_int (numerator_ratio r, big_int_of_int (-2)) &&
+test 4 eq_big_int (denominator_ratio r, zero_big_int);;
+
+let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) 
+                   (create_ratio (big_int_of_int 1) zero_big_int) in
+test 5 eq_big_int (numerator_ratio r, big_int_of_int 2) && 
+test 6 eq_big_int (denominator_ratio r, zero_big_int);;
+
+let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int) 
+                   (create_ratio (big_int_of_int 1) zero_big_int) in
+test 7 eq_big_int (numerator_ratio r, big_int_of_int 2) && 
+test 8 eq_big_int (denominator_ratio r, zero_big_int);;
+
+testing_function "div_ratio";;
+
+let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) 
+                   (create_ratio (big_int_of_int 5) (big_int_of_int 7)) in
+test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) && 
+test 2 eq_big_int (denominator_ratio r, big_int_of_int 15);;
+
+let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int) 
+                   (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
+test 3 eq_big_int (numerator_ratio r, big_int_of_int (-4)) && 
+test 4 eq_big_int (denominator_ratio r, zero_big_int);;
+
+let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) 
+                   (create_ratio (big_int_of_int 1) zero_big_int) in
+test 5 eq_big_int (numerator_ratio r, zero_big_int) && 
+test 6 eq_big_int (denominator_ratio r, big_int_of_int 3);;
+
+let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int) 
+                   (create_ratio (big_int_of_int 1) zero_big_int) in
+test 7 eq_big_int (numerator_ratio r, zero_big_int) && 
+test 8 eq_big_int (denominator_ratio r, zero_big_int);;
+
+testing_function "integer_ratio";;
+
+test 1 
+eq_big_int (integer_ratio 
+            (create_ratio (big_int_of_int 5) (big_int_of_int 3)), 
+            big_int_of_int 1);;
+test 2
+eq_big_int (integer_ratio 
+            (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), 
+            big_int_of_int (-1));;
+test 3
+eq_big_int (integer_ratio 
+            (create_ratio (big_int_of_int 3) (big_int_of_int 2)), 
+            big_int_of_int 1);;
+test 4
+eq_big_int (integer_ratio 
+            (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), 
+            big_int_of_int (-1));;
+
+failwith_test 5
+integer_ratio (create_ratio (big_int_of_int 3) zero_big_int)
+(Failure("integer_ratio "^infinite_failure));;
+
+testing_function "floor_ratio";;
+
+test 1
+eq_big_int (floor_ratio 
+            (create_ratio (big_int_of_int 5) (big_int_of_int 3)), 
+            big_int_of_int 1);;
+test 2
+eq_big_int (floor_ratio 
+            (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), 
+            big_int_of_int (-2));;
+test 3
+eq_big_int (floor_ratio 
+            (create_ratio (big_int_of_int 3) (big_int_of_int 2)), 
+            big_int_of_int 1);;
+test 4
+eq_big_int (floor_ratio 
+            (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), 
+            big_int_of_int (-2));;
+
+failwith_test 5 floor_ratio (create_ratio (big_int_of_int 3) zero_big_int)
+Division_by_zero;;
+
+
+testing_function "round_ratio";;
+
+test 1
+eq_big_int (round_ratio 
+            (create_ratio (big_int_of_int 5) (big_int_of_int 3)), 
+            big_int_of_int 2);;
+test 2
+eq_big_int (round_ratio 
+            (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), 
+            big_int_of_int (-2));;
+test 3
+eq_big_int (round_ratio 
+            (create_ratio (big_int_of_int 3) (big_int_of_int 2)), 
+            big_int_of_int 2);;
+test 4
+eq_big_int (round_ratio 
+            (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), 
+            big_int_of_int (-2));;
+
+failwith_test 5
+round_ratio (create_ratio (big_int_of_int 3) zero_big_int)
+Division_by_zero;;
+
+
+testing_function "ceiling_ratio";;
+
+test 1
+eq_big_int (ceiling_ratio 
+            (create_ratio (big_int_of_int 5) (big_int_of_int 3)), 
+            big_int_of_int 2);;
+test 2
+eq_big_int (ceiling_ratio 
+            (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), 
+            big_int_of_int (-1));;
+test 3
+eq_big_int (ceiling_ratio 
+            (create_ratio (big_int_of_int 3) (big_int_of_int 2)), 
+            big_int_of_int 2);;
+test 4
+eq_big_int (ceiling_ratio 
+            (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), 
+            big_int_of_int (-1));;
+test 5
+eq_big_int (ceiling_ratio 
+            (create_ratio (big_int_of_int 4) (big_int_of_int 2)), 
+            big_int_of_int 2);;
+failwith_test 6
+ceiling_ratio (create_ratio (big_int_of_int 3) zero_big_int)
+Division_by_zero;;
+
+testing_function "eq_ratio";;
+
+test 1
+eq_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3),
+          create_ratio (big_int_of_int (-20)) (big_int_of_int (-12)));;
+test 2
+eq_ratio (create_ratio (big_int_of_int 1) zero_big_int, 
+          create_ratio (big_int_of_int 2) zero_big_int);;
+
+let neq_ratio x y = not (eq_ratio x y);;
+
+test 3
+neq_ratio (create_ratio (big_int_of_int 1) zero_big_int,
+           create_ratio (big_int_of_int (-1)) zero_big_int);;
+test 4
+neq_ratio (create_ratio (big_int_of_int 1) zero_big_int, 
+           create_ratio zero_big_int zero_big_int);;
+test 5
+eq_ratio (create_ratio zero_big_int zero_big_int, 
+          create_ratio zero_big_int zero_big_int);;
+
+testing_function "compare_ratio";;
+
+test 1
+eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
+        0);;
+test 2
+eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
+        0);;
+test 3
+eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
+        0);;
+test 4
+eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
+        0);;
+test 5
+eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
+        0);;
+test 6
+eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
+        0);;
+test 7
+eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
+        0);;
+test 8
+eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
+        0);;
+test 9
+eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
+        0);;
+test 10
+eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 1)),
+        0);;
+test 11
+eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
+        0);;
+test 12
+eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
+        0);;
+test 13
+eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 2) (big_int_of_int 0)),
+        0);;
+test 14
+eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
+        1);;
+test 15
+eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
+        (-1));;
+test 16
+eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) 
+                       (create_ratio (big_int_of_int 1) (big_int_of_int 0)), 
+        (-1));;
+test 17
+eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
+        1);;
+test 18
+eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) 
+                       (create_ratio (big_int_of_int 1) (big_int_of_int 0)), 
+        (-1));;
+test 19
+eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
+        1);;
+test 20
+eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
+        1);;
+test 21
+eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
+        0);;
+test 22
+eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int (-2)) (big_int_of_int 0)),
+        0);;
+test 23
+eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) 
+                       (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), 
+        1);;
+test 24
+eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
+        (-1));;
+test 25
+eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) 
+                       (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), 
+        1);;
+test 26
+eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
+        (-1));;
+test 27
+eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
+        (-1));;
+test 28
+eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) 
+                       (create_ratio (big_int_of_int 3) (big_int_of_int 2)), 
+        1);;
+test 29
+eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) 
+                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)), 
+        (-1));;
+test 30
+eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) 
+                       (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)), 
+        1);;
+test 31
+eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)) 
+                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)), 
+        (-1));;
+test 32
+eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 3)), 
+        1);;
+test 33
+eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) 
+                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)), 
+        (-1));;
+test 34
+eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 3)), 
+        (-1));;
+test 35
+eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) 
+                       (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), 
+        1);;
+test 36
+eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) 
+                       (create_ratio (big_int_of_int 0) (big_int_of_int 3)), 
+        0);;
+
+testing_function "eq_big_int_ratio";;
+
+test 1
+eq_big_int_ratio (big_int_of_int 3,  
+                  (create_ratio (big_int_of_int 3) (big_int_of_int 1)));;
+test 2
+eq
+(not (eq_big_int_ratio (big_int_of_int 1) 
+                       (create_ratio (big_int_of_int 3) (big_int_of_int 1))),
+true);;
+
+test 3
+eq
+(not (eq_big_int_ratio (big_int_of_int 1) 
+                       (create_ratio (big_int_of_int 3) (big_int_of_int 2))),
+ true);;
+
+test 4
+eq
+(not (eq_big_int_ratio (big_int_of_int 1) 
+                       (create_ratio (big_int_of_int 3) (big_int_of_int 0))),
+ true);;
+
+test 5
+eq
+(not (eq_big_int_ratio (big_int_of_int 1) 
+                       (create_ratio (big_int_of_int (-3)) (big_int_of_int 2))),
+ true);;
+
+testing_function "compare_big_int_ratio";;
+
+test 1
+eq_int (compare_big_int_ratio 
+           (big_int_of_int 1) 
+            (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1));;
+test 2
+eq_int (compare_big_int_ratio 
+           (big_int_of_int 1) 
+            (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0);;
+test 3
+eq_int (compare_big_int_ratio 
+           (big_int_of_int 1) 
+            (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1);;
+test 4
+eq_int (compare_big_int_ratio 
+           (big_int_of_int (-1)) 
+            (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1));;
+test 5
+eq_int (compare_big_int_ratio 
+           (big_int_of_int (-1)) 
+            (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0);;
+test 6
+eq_int (compare_big_int_ratio 
+           (big_int_of_int (-1)) 
+            (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1);;
+test 7
+eq_int (compare_big_int_ratio 
+           (big_int_of_int 1) 
+            (create_ratio (big_int_of_int 1) (big_int_of_int 1)), 0);;
+test 8
+eq_int (compare_big_int_ratio 
+           (big_int_of_int 1) 
+            (create_ratio (big_int_of_int 3) (big_int_of_int 2)), (-1));;
+test 9
+eq_int (compare_big_int_ratio 
+           (big_int_of_int 1) 
+            (create_ratio (big_int_of_int 2) (big_int_of_int 3)), 1);;
+
+
+
+testing_function "int_of_ratio";;
+
+test 1
+eq_int (int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 2)), 
+        2);;
+
+test 2
+eq_int (int_of_ratio 
+        (create_ratio (big_int_of_int biggest_int) (big_int_of_int 1)), 
+        biggest_int);;
+
+failwith_test 3
+int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 0))
+(Failure "integer argument required");;
+
+failwith_test 4
+int_of_ratio (create_ratio (succ_big_int (big_int_of_int biggest_int)) 
+                             (big_int_of_int 1))
+(Failure "integer argument required");;
+
+failwith_test 5
+int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 3))
+(Failure "integer argument required");;
+
+testing_function "ratio_of_int";;
+
+test 1
+eq_ratio (ratio_of_int 3, 
+          create_ratio (big_int_of_int 3) (big_int_of_int 1));;
+ 
+test 2
+eq_ratio (ratio_of_nat (nat_of_int 2), 
+          create_ratio (big_int_of_int 2) (big_int_of_int 1));;
+
+testing_function "nat_of_ratio";;
+
+let nat1 = nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 1))
+and nat2 = nat_of_int 3 in
+test 1
+eq (eq_nat nat1 0 (length_nat nat1) nat2 0 (length_nat nat2), true)
+;;
+
+failwith_test 2
+nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0))
+(Failure "nat_of_ratio");;
+
+failwith_test 3
+nat_of_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 1))
+(Failure "nat_of_ratio");;
+
+failwith_test 4
+nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2))
+(Failure "nat_of_ratio");;
+
+testing_function "ratio_of_big_int";;
+
+test 1
+eq_ratio (ratio_of_big_int (big_int_of_int 3), 
+          create_ratio (big_int_of_int 3) (big_int_of_int 1));;
+
+testing_function "big_int_of_ratio";;
+
+test 1
+eq_big_int (big_int_of_ratio 
+                (create_ratio (big_int_of_int 3) (big_int_of_int 1)), 
+            big_int_of_int 3);;
+test 2
+eq_big_int (big_int_of_ratio 
+                (create_ratio (big_int_of_int (-3)) (big_int_of_int 1)),
+            big_int_of_int (-3));;
+
+failwith_test 3
+big_int_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0))
+(Failure "big_int_of_ratio");;
+
+testing_function "string_of_ratio";;
+
+test 1
+eq_string (string_of_ratio 
+              (create_ratio (big_int_of_int 43) (big_int_of_int 35)), 
+           "43/35");;
+test 2
+eq_string (string_of_ratio 
+              (create_ratio (big_int_of_int 42) (big_int_of_int 0)), 
+           "1/0");;
+
+set_normalize_ratio_when_printing false;;
+
+test 3
+eq_string (string_of_ratio 
+              (create_ratio (big_int_of_int 42) (big_int_of_int 35)), 
+           "42/35");;
+
+set_normalize_ratio_when_printing true;;
+
+test 4
+eq_string (string_of_ratio
+              (create_ratio (big_int_of_int 42) (big_int_of_int 35)), 
+           "6/5");;
+
+testing_function "ratio_of_string";;
+
+test 1
+eq_ratio (ratio_of_string ("123/3456"), 
+          create_ratio (big_int_of_int 123) (big_int_of_int 3456));;
+
+(***********
+test 2
+eq_ratio (ratio_of_string ("12.3/34.56"), 
+          create_ratio (big_int_of_int 1230) (big_int_of_int 3456));;
+test 3
+eq_ratio (ratio_of_string ("1.23/325.6"), 
+          create_ratio (big_int_of_int 123) (big_int_of_int 32560));;
+test 4
+eq_ratio (ratio_of_string ("12.3/345.6"), 
+          create_ratio (big_int_of_int 123) (big_int_of_int 3456));;
+test 5
+eq_ratio (ratio_of_string ("12.3/0.0"), 
+          create_ratio (big_int_of_int 123) (big_int_of_int 0));;
+***********)
+test 6
+eq_ratio (ratio_of_string ("0/0"), 
+          create_ratio (big_int_of_int 0) (big_int_of_int 0));;
+
+test 7
+eq_ratio (ratio_of_string "1234567890", 
+          create_ratio (big_int_of_string "1234567890") unit_big_int);;
+failwith_test 8
+ratio_of_string "frlshjkurty" (Failure "invalid digit");;
+
+(***********
+testing_function "msd_ratio";;
+
+test 1
+eq_int (msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)),
+        0);;
+test 2
+eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 12)),
+        (-2));;
+test 3
+eq_int (msd_ratio (create_ratio (big_int_of_int 12) (big_int_of_int 1)),
+        1);;
+test 4
+eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)),
+        (-1));;
+test 5
+eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 1)),
+        0);;
+test 6
+eq_int (msd_ratio (create_ratio (big_int_of_int 25) (big_int_of_int 21)),
+        0);;
+test 7
+eq_int (msd_ratio (create_ratio (big_int_of_int 35) (big_int_of_int 21)),
+        0);;
+test 8
+eq_int (msd_ratio (create_ratio (big_int_of_int 215) (big_int_of_int 31)),
+        0);;
+test 9
+eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 30)),
+        (-2));;
+test 10
+eq_int (msd_ratio (create_ratio (big_int_of_int 2345) 
+                                     (big_int_of_int 23456)),
+        (-2));;
+test 11
+eq_int (msd_ratio (create_ratio (big_int_of_int 2345) 
+                                     (big_int_of_int 2346)),
+        (-1));;
+test 12
+eq_int (msd_ratio (create_ratio (big_int_of_int 2345) 
+                                     (big_int_of_int 2344)),
+        0);;
+test 13
+eq_int (msd_ratio (create_ratio (big_int_of_int 23456) 
+                                     (big_int_of_int 2345)),
+        1);;
+test 14
+eq_int (msd_ratio (create_ratio (big_int_of_int 23467) 
+                                     (big_int_of_int 2345)),
+        1);;
+failwith_test 15
+msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
+("msd_ratio "^infinite_failure);;
+failwith_test 16
+msd_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
+("msd_ratio "^infinite_failure);;
+failwith_test 17
+msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
+("msd_ratio "^infinite_failure);;
+*************************)
+
+testing_function "round_futur_last_digit";;
+
+let s = "+123456" in
+test 1 eq (round_futur_last_digit s 1 (pred (String.length s)), 
+            false) &&
+test 2 eq_string (s, "+123466");;
+
+let s = "123456" in
+test 3 eq (round_futur_last_digit s 0 (String.length s), false) &&
+test 4 eq_string (s, "123466");;
+
+let s = "-123456" in
+test 5 eq (round_futur_last_digit s 1 (pred (String.length s)),
+            false) &&
+test 6 eq_string (s, "-123466");;
+
+let s = "+123496" in
+test 7 eq (round_futur_last_digit s 1 (pred (String.length s)),
+            false) &&
+test 8 eq_string (s, "+123506");;
+
+let s = "123496" in
+test 9 eq (round_futur_last_digit s 0 (String.length s), false) &&
+test 10 eq_string (s, "123506");;
+
+let s = "-123496" in
+test 11 eq (round_futur_last_digit s 1 (pred (String.length s)),
+            false) &&
+test 12 eq_string (s, "-123506");;
+
+let s = "+996" in
+test 13 eq (round_futur_last_digit s 1 (pred (String.length s)), 
+            true) &&
+test 14 eq_string (s, "+006");;
+
+let s = "996" in
+test 15 eq (round_futur_last_digit s 0 (String.length s), true) &&
+test 16 eq_string (s, "006");;
+
+let s = "-996" in
+test 17 eq (round_futur_last_digit s 1 (pred (String.length s)), 
+             true) &&
+test 18 eq_string (s, "-006");;
+
+let s = "+6666666" in
+test 19 eq (round_futur_last_digit s 1 (pred (String.length s)), 
+             false) &&
+test 20 eq_string (s, "+6666676") ;; 
+
+let s = "6666666" in
+test 21 eq (round_futur_last_digit s 0 (String.length s), false) &&
+test 22 eq_string (s, "6666676") ;; 
+
+let s = "-6666666" in
+test 23 eq (round_futur_last_digit s 1 (pred (String.length s)), 
+             false) &&
+test 24 eq_string (s, "-6666676") ;; 
+
+testing_function "approx_ratio_fix";;
+
+let s = approx_ratio_fix 5 
+                          (create_ratio (big_int_of_int 2) 
+                                        (big_int_of_int 3)) in
+test 1
+eq_string (s, "+0.66667");;
+
+test 2
+eq_string (approx_ratio_fix 5 
+                             (create_ratio (big_int_of_int 20) 
+                                           (big_int_of_int 3)), 
+           "+6.66667");;
+test 3
+eq_string (approx_ratio_fix 5 
+                             (create_ratio (big_int_of_int 2) 
+                                           (big_int_of_int 30)),
+           "+0.06667");;
+test 4
+eq_string (approx_ratio_fix 5 
+                             (create_ratio (big_int_of_string "999996") 
+                                           (big_int_of_string "1000000")), 
+           "+1.00000");;
+test 5
+eq_string (approx_ratio_fix 5 
+                             (create_ratio (big_int_of_string "299996") 
+                                           (big_int_of_string "100000")), 
+           "+2.99996");;
+test 6
+eq_string (approx_ratio_fix 5 
+                             (create_ratio (big_int_of_string "2999996") 
+                                           (big_int_of_string "1000000")), 
+           "+3.00000");;
+test 7
+eq_string (approx_ratio_fix 4 
+                             (create_ratio (big_int_of_string "299996") 
+                                           (big_int_of_string "100000")), 
+           "+3.0000");;
+test 8
+eq_string (approx_ratio_fix 5 
+                             (create_ratio (big_int_of_int 29996) 
+                                           (big_int_of_string "100000")), 
+           "+0.29996");;
+test 9
+eq_string (approx_ratio_fix 5 
+                             (create_ratio (big_int_of_int 0) 
+                                           (big_int_of_int 1)), 
+           "+0");;
+failwith_test 10
+(approx_ratio_fix 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0))
+(Failure "approx_ratio_fix infinite or undefined rational number");;
+failwith_test 11
+(approx_ratio_fix 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0))
+(Failure "approx_ratio_fix infinite or undefined rational number");;
+
+testing_function "approx_ratio_exp";;
+
+test 1
+eq_string (approx_ratio_exp 5 
+                             (create_ratio (big_int_of_int 2) 
+                                           (big_int_of_int 3)), 
+           "+0.66667e0");;
+test 2
+eq_string (approx_ratio_exp 5 
+                             (create_ratio (big_int_of_int 20) 
+                                           (big_int_of_int 3)), 
+           "+0.66667e1");;
+test 3
+eq_string (approx_ratio_exp 5 
+                             (create_ratio (big_int_of_int 2) 
+                                           (big_int_of_int 30)), 
+           "+0.66667e-1");;
+test 4
+eq_string (approx_ratio_exp 5 
+                             (create_ratio (big_int_of_string "999996") 
+                                           (big_int_of_string "1000000")), 
+           "+1.00000e0");;
+test 5
+eq_string (approx_ratio_exp 5 
+                             (create_ratio (big_int_of_string "299996") 
+                                           (big_int_of_string "100000")), 
+           "+0.30000e1");;
+test 6
+eq_string (approx_ratio_exp 5 
+                             (create_ratio (big_int_of_int 29996) 
+                                           (big_int_of_string "100000")), 
+           "+0.29996e0");;
+test 7
+eq_string (approx_ratio_exp 5 
+                             (create_ratio (big_int_of_int 0) 
+                                           (big_int_of_int 1)), 
+           "+0.00000e0");;
+failwith_test 8
+(approx_ratio_exp 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0))
+(Failure "approx_ratio_exp infinite or undefined rational number");;
+failwith_test 9
+(approx_ratio_exp 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0))
+(Failure "approx_ratio_exp infinite or undefined rational number");;
diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend
index c93656ba..782f7c48 100644
--- a/otherlibs/str/.depend
+++ b/otherlibs/str/.depend
@@ -1,7 +1,7 @@
-strstubs.o: strstubs.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h ../../byterun/fail.h
+strstubs.o: strstubs.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h
 str.cmo: str.cmi 
 str.cmx: str.cmi 
diff --git a/otherlibs/str/Makefile.Mac b/otherlibs/str/Makefile.Mac
deleted file mode 100644
index cf5c8e65..00000000
--- a/otherlibs/str/Makefile.Mac
+++ /dev/null
@@ -1,53 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#            Damien Doligez, projet Para, INRIA Rocquencourt            #
-#                                                                       #
-#   Copyright 1999 Institut National de Recherche en Informatique et    #
-#   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the GNU Library General Public License, with     #
-#   the special exception on linking described in file ../../LICENSE.   #
-#                                                                       #
-#########################################################################
-
-# $Id: Makefile.Mac,v 1.12 2002/12/09 14:05:18 xleroy Exp $
-
-# Makefile for the str library
-
-# Compilation options
-PPCC = mrc
-PPCCOptions = -i :::byterun:,:::config: -w 7 {cdbgflag}
-
-CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib:
-
-PPCCOBJS = strstubs.c.x
-
-all Ä libstr.x str.cmi str.cma
-
-libstr.x Ä {PPCCOBJS}
-    ppclink {ldbgflag} -xm library -o libstr.x {PPCCOBJS}
-
-str.cma Ä str.cmo
-    {CAMLC} -a -o str.cma str.cmo
-
-partialclean Ä
-    delete -i Å.cm[aio] || set status 0
-
-clean Ä partialclean
-    delete -i Å.x || set status 0
-
-install Ä
-    duplicate -y libstr.x str.cma str.cmi "{LIBDIR}"
-
-.cmi Ä .mli
-    {CAMLC} -c {COMPFLAGS} {default}.mli
-
-.cmo Ä .ml
-    {CAMLC} -c {COMPFLAGS} {default}.ml
-
-depend Ä
-    begin
-      MakeDepend -w -objext .x Å.c
-      :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml
-    end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/otherlibs/str/Makefile.Mac.depend b/otherlibs/str/Makefile.Mac.depend
deleted file mode 100644
index ddcc070e..00000000
--- a/otherlibs/str/Makefile.Mac.depend
+++ /dev/null
@@ -1,16 +0,0 @@
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 20:33:21 on Tue, Aug 21, 2001 by MakeDepend
-
-:strstubs.c.x Ä  ¶
- :strstubs.c ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-str.cmoÄ str.cmi 
-str.cmxÄ str.cmi 
diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml
index e57e19dd..c3ab7ed2 100644
--- a/otherlibs/str/str.ml
+++ b/otherlibs/str/str.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: str.ml,v 1.18 2002/12/20 10:32:46 xleroy Exp $ *)
+(* $Id: str.ml,v 1.19 2004/02/17 10:13:50 xleroy Exp $ *)
 
 (** String utilities *)
 
@@ -665,6 +665,12 @@ and replace_first expr repl text =
 
 (** Splitting *)
 
+let search_forward_progress expr text start =
+  let pos = search_forward expr text start in
+  if match_end() = start && start < String.length text
+  then search_forward expr text (start + 1)
+  else pos
+
 let bounded_split expr text num =
   let start =
     if string_match expr text 0 then match_end() else 0 in
@@ -672,7 +678,7 @@ let bounded_split expr text num =
     if start >= String.length text then [] else
     if n = 1 then [string_after text start] else
       try
-        let pos = search_forward expr text start in
+        let pos = search_forward_progress expr text start in
         String.sub text start (pos-start) :: split (match_end()) (n-1)
       with Not_found ->
         [string_after text start] in
@@ -685,7 +691,7 @@ let bounded_split_delim expr text num =
     if start > String.length text then [] else
     if n = 1 then [string_after text start] else
       try
-        let pos = search_forward expr text start in
+        let pos = search_forward_progress expr text start in
         String.sub text start (pos-start) :: split (match_end()) (n-1)
       with Not_found ->
         [string_after text start] in
@@ -700,7 +706,7 @@ let bounded_full_split expr text num =
     if start >= String.length text then [] else
     if n = 1 then [Text(string_after text start)] else
       try
-        let pos = search_forward expr text start in
+        let pos = search_forward_progress expr text start in
         let s = matched_string text in
         if pos > start then
           Text(String.sub text start (pos-start)) ::
diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli
index b71d2f17..0ea879bc 100644
--- a/otherlibs/str/str.mli
+++ b/otherlibs/str/str.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: str.mli,v 1.21 2003/09/23 15:41:44 doligez Exp $ *)
+(* $Id: str.mli,v 1.23 2004/04/13 17:12:46 doligez Exp $ *)
 
 (** Regular expressions and high-level string processing *)
 
@@ -24,26 +24,32 @@ type regexp
 
 
 val regexp : string -> regexp
-(** Compile a regular expression. The syntax for regular expressions
-   is the same as in Gnu Emacs. The special characters are
-   [$^.*+?[]]. The following constructs are recognized:
-   - [.     ] matches any character except newline
-   - [*     ] (postfix) matches the previous expression zero, one or
+(** Compile a regular expression. The following constructs are
+    recognized:
+   - [.     ] Matches any character except newline.
+   - [*     ] (postfix) Matches the preceding expression zero, one or
               several times
-   - [+     ] (postfix) matches the previous expression one or
+   - [+     ] (postfix) Matches the preceding expression one or
               several times
-   - [?     ] (postfix) matches the previous expression once or
+   - [?     ] (postfix) Matches the preceding expression once or
               not at all
-   - [[..]  ] character set; ranges are denoted with [-], as in [[a-z]];
-              an initial [^], as in [[^0-9]], complements the set
-   - [^     ] matches at beginning of line
-   - [$     ] matches at end of line
-   - [\|    ] (infix) alternative between two expressions
-   - [\(..\)] grouping and naming of the enclosed expression
-   - [\1    ] the text matched by the first [\(...\)] expression
-     ([\2] for the second expression, and so on up to [\9])
-   - [\b    ] matches word boundaries
-   - [\     ] quotes special characters. *)
+   - [[..]  ] Character set. Ranges are denoted with [-], as in [[a-z]].
+              An initial [^], as in [[^0-9]], complements the set.
+              To include a [\]] character in a set, make it the first
+              character of the set. To include a [-] character in a set,
+              make it the first or the last character of the set.
+   - [^     ] Matches at beginning of line (either at the beginning of
+              the matched string, or just after a newline character).
+   - [$     ] Matches at end of line (either at the end of the matched
+              string, or just before a newline character).
+   - [\|    ] (infix) Alternative between two expressions.
+   - [\(..\)] Grouping and naming of the enclosed expression.
+   - [\1    ] The text matched by the first [\(...\)] expression
+     ([\2] for the second expression, and so on up to [\9]).
+   - [\b    ] Matches word boundaries.
+   - [\     ] Quotes special characters.  The special characters
+              are [$^.*+?[]].
+*)
 
 val regexp_case_fold : string -> regexp
 (** Same as [regexp], but the compiled expression will match text
@@ -72,15 +78,19 @@ val string_match : regexp -> string -> int -> bool
    The first character of a string has position [0], as usual. *)
 
 val search_forward : regexp -> string -> int -> int
-(** [search_forward r s start] searchs the string [s] for a substring
+(** [search_forward r s start] searches the string [s] for a substring
    matching the regular expression [r]. The search starts at position
    [start] and proceeds towards the end of the string.
    Return the position of the first character of the matched
    substring, or raise [Not_found] if no substring matches. *)
 
 val search_backward : regexp -> string -> int -> int
-(** Same as {!Str.search_forward}, but the search proceeds towards the
-   beginning of the string. *)
+(** [search_backward r s last] searches the string [s] for a
+  substring matching the regular expression [r]. The search first
+  considers substrings that start at position [last] and proceeds
+  towards the beginning of string. Return the position of the first
+  character of the matched substring; raise [Not_found] if no
+  substring matches. *)
 
 val string_partial_match : regexp -> string -> int -> bool
 (** Similar to {!Str.string_match}, but succeeds whenever the argument
diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c
index 3cf02554..1b77653f 100644
--- a/otherlibs/str/strstubs.c
+++ b/otherlibs/str/strstubs.c
@@ -11,9 +11,8 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: strstubs.c,v 1.24 2003/01/02 09:14:35 xleroy Exp $ */
+/* $Id: strstubs.c,v 1.26 2004/05/17 17:10:00 doligez Exp $ */
 
-#include <assert.h>
 #include <string.h>
 #include <ctype.h>
 #include <mlvalues.h>
@@ -283,7 +282,7 @@ static int re_match(value re,
       break;
     }
     default:
-      assert(0);
+      caml_fatal_error ("impossible case in re_match");
     }
     /* Continue with next instruction */
     continue;
@@ -402,7 +401,6 @@ CAMLprim value re_search_forward(value re, value str, value startpos)
   unsigned char * txt = &Byte_u(str, Long_val(startpos));
   unsigned char * endtxt = &Byte_u(str, string_length(str));
   unsigned char * startchars;
-  unsigned char c;
 
   if (txt < starttxt || txt > endtxt)
     invalid_argument("Str.search_forward");
@@ -432,7 +430,6 @@ CAMLprim value re_search_backward(value re, value str, value startpos)
   unsigned char * txt = &Byte_u(str, Long_val(startpos));
   unsigned char * endtxt = &Byte_u(str, string_length(str));
   unsigned char * startchars;
-  unsigned char c;
 
   if (txt < starttxt || txt > endtxt)
     invalid_argument("Str.search_backward");
diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend
index 6fdbf1c6..e904871a 100644
--- a/otherlibs/systhreads/.depend
+++ b/otherlibs/systhreads/.depend
@@ -1,14 +1,14 @@
-posix.o: posix.c ../../byterun/alloc.h ../../byterun/misc.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/mlvalues.h ../../byterun/backtrace.h \
+posix.o: posix.c ../../byterun/alloc.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/mlvalues.h ../../byterun/backtrace.h \
   ../../byterun/callback.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/printexc.h ../../byterun/roots.h \
   ../../byterun/signals.h ../../byterun/stacks.h ../../byterun/sys.h
-win32.o: win32.c ../../byterun/alloc.h ../../byterun/misc.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/mlvalues.h ../../byterun/backtrace.h \
+win32.o: win32.c ../../byterun/alloc.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/mlvalues.h ../../byterun/backtrace.h \
   ../../byterun/callback.h ../../byterun/custom.h ../../byterun/fail.h \
   ../../byterun/io.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
diff --git a/otherlibs/systhreads/Makefile.Mac b/otherlibs/systhreads/Makefile.Mac
deleted file mode 100644
index c7cdffbe..00000000
--- a/otherlibs/systhreads/Makefile.Mac
+++ /dev/null
@@ -1,78 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#          Damien Doligez, projet Moscova, 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.4 2001/12/07 13:40:18 xleroy Exp $
-
-# systhread library
-# not supported yet: too many bugs in GUSI and in posix.c.
-
-C = sc
-COptions = -includes unix -i ":::byterun:,:::config:,{GUSI}include:" -w 35 ¶
-           {cdbgflag} -model far
-
-PPCC = mrc
-PPCCOptions = -includes unix -i ":::byterun:,:::config:,{GUSI}include:" -w 35 ¶
-              {cdbgflag}
-
-CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib: -I ::unix:
-
-C_OBJS = posix.c.o
-PPCC_OBJS = posix.c.x
-
-THREAD_OBJS = thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
-THREAD_INTF = thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi
-
-GENFILES = thread.ml
-
-all Ä libthreads.x libthreads.o threads.cma
-
-libthreads.x Ä {PPCC_OBJS}
-    ppclink {ldbgflag} -xm library -o libthreads.x {PPCC_OBJS}
-
-libthreads.o Ä {C_OBJS}
-    lib {ldbgflag} -o libthreads.o {C_OBJS}
-
-threads.cma Ä {THREAD_OBJS}
-    {CAMLC} -a -o threads.cma -custom {THREAD_OBJS}
-
-thread.ml Ä thread_posix.ml
-    duplicate -y thread_posix.ml thread.ml
-
-partialclean Ä
-    delete -i Å.cmÅ || set status 0
-
-clean Ä partialclean
-    delete -i Å.[ox] || set status 0
-    delete -i {GENFILES}
-
-install Ä
-    duplicate -y libthreads.x libthreads.o "{LIBDIR}"
-    if "`exists "{LIBDIR}threads"`" == ""
-      newfolder "{LIBDIR}threads"
-    end
-    duplicate -y {THREAD_INTF} threads.cma "{LIBDIR}threads"
-    duplicate -y thread.mli mutex.mli condition.mli event.mli threadUnix.mli ¶
-              "{LIBDIR}"
-
-.cmi Ä .mli
-    {CAMLC} -c {COMPFLAGS} {depdir}{default}.mli
-
-.cmo Ä .ml
-    {CAMLC} -c {COMPFLAGS} {depdir}{default}.ml
-
-depend Ä {GENFILES}
-    begin
-      MakeDepend -w -objext .x Å.c
-      MakeDepend -w Å.c
-      :::boot:ocamlrun :::tools:ocamldep -I :::stdlib: -I ::unix: Å.mli Å.ml
-    end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/otherlibs/systhreads/Makefile.Mac.depend b/otherlibs/systhreads/Makefile.Mac.depend
deleted file mode 100644
index e9a4ee13..00000000
--- a/otherlibs/systhreads/Makefile.Mac.depend
+++ /dev/null
@@ -1,131 +0,0 @@
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 23:43:37 on 27 fŽv 2001 by MakeDepend
-
-:posix.c.x Ä  ¶
- :posix.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:win32.c.x Ä  ¶
- :win32.c ¶
- "{CIncludes}"windows.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"MacMemory.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}"AppleTalk.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"DateTimeUtils.h
-
-#*** Dependencies: Cut here ***
-# These dependencies were produced at 23:43:42 on 27 fŽv 2001 by MakeDepend
-
-:posix.c.o Ä  ¶
- :posix.c ¶
- "{CIncludes}"errno.h ¶
- "{CIncludes}"string.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"NullDef.h ¶
- "{CIncludes}"SizeTDef.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacMemory.h ¶
- "{CIncludes}"MacTypes.h ¶
- "{CIncludes}"MixedMode.h
-
-:win32.c.o Ä  ¶
- :win32.c ¶
- "{CIncludes}"windows.h ¶
- "{CIncludes}"signal.h ¶
- "{CIncludes}"memory.h ¶
- "{CIncludes}"ConditionalMacros.h ¶
- "{CIncludes}"MacWindows.h ¶
- "{CIncludes}"MacMemory.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}"AppleTalk.h ¶
- "{CIncludes}"Files.h ¶
- "{CIncludes}"Notification.h ¶
- "{CIncludes}"AEDataModel.h ¶
- "{CIncludes}"OSUtils.h ¶
- "{CIncludes}"Endian.h ¶
- "{CIncludes}"Fonts.h ¶
- "{CIncludes}"Processes.h ¶
- "{CIncludes}"Components.h ¶
- "{CIncludes}"QuickdrawText.h ¶
- "{CIncludes}"CodeFragments.h ¶
- "{CIncludes}"UTCUtils.h ¶
- "{CIncludes}"Finder.h ¶
- "{CIncludes}"Patches.h ¶
- "{CIncludes}"DateTimeUtils.h
-
-condition.cmiÄ mutex.cmi 
-thread.cmiÄ ::unix:unix.cmi 
-threadUnix.cmiÄ ::unix:unix.cmi 
-condition.cmoÄ mutex.cmi condition.cmi 
-condition.cmxÄ mutex.cmx condition.cmi 
-event.cmoÄ :::stdlib:array.cmi condition.cmi :::stdlib:list.cmi mutex.cmi ¶
-    :::stdlib:queue.cmi :::stdlib:random.cmi event.cmi 
-event.cmxÄ :::stdlib:array.cmx condition.cmx :::stdlib:list.cmx mutex.cmx ¶
-    :::stdlib:queue.cmx :::stdlib:random.cmx event.cmi 
-mutex.cmoÄ mutex.cmi 
-mutex.cmxÄ mutex.cmi 
-thread.cmoÄ :::stdlib:printexc.cmi :::stdlib:printf.cmi :::stdlib:sys.cmi ¶
-    ::unix:unix.cmi thread.cmi 
-thread.cmxÄ :::stdlib:printexc.cmx :::stdlib:printf.cmx :::stdlib:sys.cmx ¶
-    ::unix:unix.cmx thread.cmi 
-thread_posix.cmoÄ :::stdlib:printexc.cmi :::stdlib:printf.cmi ¶
-    :::stdlib:sys.cmi ::unix:unix.cmi 
-thread_posix.cmxÄ :::stdlib:printexc.cmx :::stdlib:printf.cmx ¶
-    :::stdlib:sys.cmx ::unix:unix.cmx 
-thread_win32.cmoÄ :::stdlib:printexc.cmi :::stdlib:printf.cmi ¶
-    :::stdlib:sys.cmi ::unix:unix.cmi 
-thread_win32.cmxÄ :::stdlib:printexc.cmx :::stdlib:printf.cmx ¶
-    :::stdlib:sys.cmx ::unix:unix.cmx 
-threadUnix.cmoÄ thread.cmi ::unix:unix.cmi threadUnix.cmi 
-threadUnix.cmxÄ thread.cmx ::unix:unix.cmx threadUnix.cmi 
diff --git a/otherlibs/systhreads/Tests/Makefile b/otherlibs/systhreads/Tests/Makefile
new file mode 100644
index 00000000..7745fdc7
--- /dev/null
+++ b/otherlibs/systhreads/Tests/Makefile
@@ -0,0 +1,44 @@
+#########################################################################
+#                                                                       #
+#                            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.11 2003/06/16 12:31:14 xleroy Exp $
+
+PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \
+  test7.byt test8.byt test9.byt testA.byt sieve.byt \
+  testio.byt testsocket.byt testsignal.byt testsignal2.byt \
+  torture.byt
+
+include ../../../config/Makefile
+
+CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../unix -I ../../../stdlib 
+
+CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I .. -I ../../unix -I ../../../stdlib 
+
+all: $(PROGS)
+
+allopt: $(PROGS:.byt=.out)
+
+clean:
+	rm -f *.cm* *.byt *.out
+	rm -f $(PROGS:.byt=.ml)
+
+%.byt: ../../threads/Tests/%.ml
+	cp ../../threads/Tests/$*.ml $*.ml
+	$(CAMLC) -custom -o $*.byt unix.cma threads.cma $*.ml ../libthreads.a ../../unix/libunix.a -cclib -lpthread
+
+%.out: ../../threads/Tests/%.ml
+	cp ../../threads/Tests/$*.ml $*.ml
+	$(CAMLOPT) -o $*.out unix.cmxa threads.cmxa $*.ml ../libthreadsnat.a ../../unix/libunix.a -cclib -lpthread
+
+$(PROGS): ../threads.cma ../libthreads.a
+$(PROGS:.byt=.out): ../threads.cmxa ../libthreadsnat.a
diff --git a/otherlibs/systhreads/Tests/Makefile.nt b/otherlibs/systhreads/Tests/Makefile.nt
new file mode 100644
index 00000000..3049de79
--- /dev/null
+++ b/otherlibs/systhreads/Tests/Makefile.nt
@@ -0,0 +1,43 @@
+#########################################################################
+#                                                                       #
+#                            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.8 2002/06/11 08:30:19 xleroy Exp $
+
+PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \
+  test7.byt test8.byt test9.byt testA.byt sieve.byt \
+  testio.byt testsocket.byt testwait.byt testsignal.byt testsignal2.byt \
+  torture.byt
+
+include ../../../config/Makefile
+
+CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../unix -I ../../../stdlib 
+
+CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I .. -I ../../unix -I ../../../stdlib 
+
+all: $(PROGS)
+
+allopt: $(PROGS:.byt=.out)
+
+clean:
+	rm -f *.cm* *.byt *.out
+	rm -f $(PROGS:.byt=.ml)
+
+%.byt: ../../threads/Tests/%.ml
+	cp ../../threads/Tests/$*.ml $*.ml
+	$(CAMLC) -custom -o $*.byt unix.cma threads.cma $*.ml ../libthreads.$(A) ../../unix/libunix.$(A)
+
+%.out: ../../threads/Tests/%.ml
+	cp ../../threads/Tests/$*.ml $*.ml
+	$(CAMLOPT) -o $*.out unix.cmxa threads.cmxa $*.ml ../libthreadsnat.$(A) ../../unix/libunix.$(A) -cclib -lpthread
+
+$(PROGS): ../threads.cma ../libthreads.$(A)
diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c
index 958c2dfb..f7aa4bc7 100644
--- a/otherlibs/systhreads/posix.c
+++ b/otherlibs/systhreads/posix.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: posix.c,v 1.47 2003/07/29 15:35:12 xleroy Exp $ */
+/* $Id: posix.c,v 1.49.2.1 2004/07/01 09:32:38 xleroy Exp $ */
 
 /* Thread interface for POSIX 1003.1c threads */
 
@@ -27,6 +27,7 @@
 #include <sys/time.h>
 #ifdef __linux__
 #include <unistd.h>
+#include <sys/utsname.h>
 #endif
 #include "alloc.h"
 #include "backtrace.h"
@@ -96,12 +97,20 @@ struct caml_thread_struct {
 typedef struct caml_thread_struct * caml_thread_t;
 
 /* The descriptor for the currently executing thread */
-
 static caml_thread_t curr_thread = NULL;
 
-/* The global mutex used to ensure that at most one thread is running
-   Caml code */
-static pthread_mutex_t caml_mutex;
+/* Track whether one thread is running Caml code.  There can be
+   at most one such thread at any time. */
+static volatile int caml_runtime_busy = 1;
+
+/* Number of threads waiting to run Caml code. */
+static volatile int caml_runtime_waiters = 0;
+
+/* Mutex that protects the two variables above. */
+static pthread_mutex_t caml_runtime_mutex = PTHREAD_MUTEX_INITIALIZER;
+
+/* Condition signaled when caml_runtime_busy becomes 0 */
+static pthread_cond_t caml_runtime_is_free = PTHREAD_COND_INITIALIZER;
 
 /* The key used for storing the thread descriptor in the specific data
    of the corresponding Posix thread. */
@@ -113,11 +122,15 @@ static pthread_key_t last_channel_locked_key;
 /* Identifier for next thread creation */
 static long thread_next_ident = 0;
 
+/* Whether to use sched_yield() or not */
+static int broken_sched_yield = 0;
+
 /* Forward declarations */
 value caml_threadstatus_new (void);
 void caml_threadstatus_terminate (value);
 int caml_threadstatus_wait (value);
 static void caml_pthread_check (int, char *);
+static void caml_thread_sysdeps_initialize(void);
 
 /* Imports for the native-code compiler */
 extern struct longjmp_buffer caml_termination_jmpbuf;
@@ -182,14 +195,24 @@ static void caml_thread_enter_blocking_section(void)
   curr_thread->backtrace_buffer = backtrace_buffer;
   curr_thread->backtrace_last_exn = backtrace_last_exn;
 #endif
-  /* Release the global mutex */
-  pthread_mutex_unlock(&caml_mutex);
+  /* Tell other threads that the runtime is free */
+  pthread_mutex_lock(&caml_runtime_mutex);
+  caml_runtime_busy = 0;
+  pthread_mutex_unlock(&caml_runtime_mutex);
+  pthread_cond_signal(&caml_runtime_is_free);
 }
 
 static void caml_thread_leave_blocking_section(void)
 {
-  /* Re-acquire the global mutex */
-  pthread_mutex_lock(&caml_mutex);
+  /* Wait until the runtime is free */
+  pthread_mutex_lock(&caml_runtime_mutex);
+  while (caml_runtime_busy) {
+    caml_runtime_waiters++;
+    pthread_cond_wait(&caml_runtime_is_free, &caml_runtime_mutex);
+    caml_runtime_waiters--;
+  }
+  caml_runtime_busy = 1;
+  pthread_mutex_unlock(&caml_runtime_mutex);
   /* Update curr_thread to point to the thread descriptor corresponding
      to the thread currently executing */
   curr_thread = pthread_getspecific(thread_descriptor_key);
@@ -314,10 +337,8 @@ value caml_thread_initialize(value unit)   /* ML */
   /* Protect against repeated initialization (PR#1325) */
   if (curr_thread != NULL) return Val_unit;
   Begin_root (mu);
-    /* Initialize the main mutex */
-    caml_pthread_check(pthread_mutex_init(&caml_mutex, NULL),
-                       "Thread.init");
-    pthread_mutex_lock(&caml_mutex);
+    /* OS-specific initialization */
+    caml_thread_sysdeps_initialize();
     /* Initialize the keys */
     pthread_key_create(&thread_descriptor_key, NULL);
     pthread_key_create(&last_channel_locked_key, NULL);
@@ -353,10 +374,10 @@ value caml_thread_initialize(value unit)   /* ML */
 #ifdef NATIVE_CODE
     caml_termination_hook = pthread_exit;
 #endif
-    channel_mutex_free = caml_io_mutex_free;
-    channel_mutex_lock = caml_io_mutex_lock;
-    channel_mutex_unlock = caml_io_mutex_unlock;
-    channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
+    caml_channel_mutex_free = caml_io_mutex_free;
+    caml_channel_mutex_lock = caml_io_mutex_lock;
+    caml_channel_mutex_unlock = caml_io_mutex_unlock;
+    caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
     /* Fork the tick thread */
     pthread_attr_init(&attr);
     pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
@@ -378,9 +399,12 @@ static void caml_thread_stop(void)
   /* Remove th from the doubly-linked list of threads */
   th->next->prev = th->prev;
   th->prev->next = th->next;
-  /* Release the main mutex (forever) */
+  /* Release the runtime system */
   async_signal_mode = 1;
-  pthread_mutex_unlock(&caml_mutex);
+  pthread_mutex_lock(&caml_runtime_mutex);
+  caml_runtime_busy = 0;
+  pthread_mutex_unlock(&caml_runtime_mutex);
+  pthread_cond_signal(&caml_runtime_is_free);
 #ifndef NATIVE_CODE
   /* Free the memory resources */
   stat_free(th->stack_low);
@@ -396,7 +420,9 @@ static void * caml_thread_start(void * arg)
 {
   caml_thread_t th = (caml_thread_t) arg;
   value clos;
+#ifdef NATIVE_CODE
   struct longjmp_buffer termination_buf;
+#endif
 
   /* Associate the thread descriptor with the thread */
   pthread_setspecific(thread_descriptor_key, (void *) th);
@@ -537,8 +563,9 @@ value caml_thread_exit(value unit)   /* ML */
 
 value caml_thread_yield(value unit)        /* ML */
 {
+  if (caml_runtime_waiters == 0) return Val_unit;
   enter_blocking_section();
-  sched_yield();
+  if (! broken_sched_yield) sched_yield();
   leave_blocking_section();
   return Val_unit;
 }
@@ -818,3 +845,21 @@ static void caml_pthread_check(int retcode, char *msg)
   memmove (&Byte(str, msglen + 2), err, errlen);
   raise_sys_error(str);
 }
+
+/* OS-specific initialization */
+
+static void caml_thread_sysdeps_initialize(void)
+{
+#ifdef __linux__
+  /* sched_yield() doesn't do what we want in kernel 2.6 and up (PR#2663) */
+  struct utsname un;
+  if (uname(&un) == -1) return;
+  broken_sched_yield =
+    un.release[1] != '.' || un.release[0] >= '3'   /* version 3 and up */
+    || (un.release[0] == '2' &&
+        (un.release[3] != '.' || un.release[2] >= '6')); /* 2.6 and up */
+  caml_gc_message(0x100, "POSIX threads.  Avoid sched_yield: %d\n",
+                  broken_sched_yield);
+#endif
+}
+
diff --git a/otherlibs/systhreads/win32.c b/otherlibs/systhreads/win32.c
index 6a033878..c06be439 100644
--- a/otherlibs/systhreads/win32.c
+++ b/otherlibs/systhreads/win32.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: win32.c,v 1.37 2002/12/02 15:05:18 xleroy Exp $ */
+/* $Id: win32.c,v 1.38 2003/12/29 22:15:02 doligez Exp $ */
 
 /* Thread interface for Win32 threads */
 
@@ -319,10 +319,10 @@ CAMLprim value caml_thread_initialize(value unit)
     enter_blocking_section_hook = caml_thread_enter_blocking_section;
     prev_leave_blocking_section_hook = leave_blocking_section_hook;
     leave_blocking_section_hook = caml_thread_leave_blocking_section;
-    channel_mutex_free = caml_io_mutex_free;
-    channel_mutex_lock = caml_io_mutex_lock;
-    channel_mutex_unlock = caml_io_mutex_unlock;
-    channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
+    caml_channel_mutex_free = caml_io_mutex_free;
+    caml_channel_mutex_lock = caml_io_mutex_lock;
+    caml_channel_mutex_unlock = caml_io_mutex_unlock;
+    caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
     /* Fork the tick thread */
     tick_thread = (HANDLE) _beginthread(caml_thread_tick, 0, NULL);
     if (tick_thread == (HANDLE)(-1)) caml_wthread_error("Thread.init");
diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend
index d73c31e4..fb931c6e 100644
--- a/otherlibs/threads/.depend
+++ b/otherlibs/threads/.depend
@@ -1,4 +1,5 @@
-scheduler.o: scheduler.c ../../byterun/alloc.h ../../byterun/misc.h \
+scheduler.o: scheduler.c ../../byterun/alloc.h \
+  ../../byterun/compatibility.h ../../byterun/misc.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/mlvalues.h ../../byterun/backtrace.h \
   ../../byterun/callback.h ../../byterun/fail.h ../../byterun/io.h \
diff --git a/otherlibs/threads/Tests/.cvsignore b/otherlibs/threads/Tests/.cvsignore
new file mode 100644
index 00000000..e6d9e45b
--- /dev/null
+++ b/otherlibs/threads/Tests/.cvsignore
@@ -0,0 +1 @@
+*.byt
diff --git a/otherlibs/threads/Tests/Makefile b/otherlibs/threads/Tests/Makefile
new file mode 100644
index 00000000..8d3e3eb1
--- /dev/null
+++ b/otherlibs/threads/Tests/Makefile
@@ -0,0 +1,38 @@
+#########################################################################
+#                                                                       #
+#                            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.15 2001/12/07 13:40:23 xleroy Exp $
+
+PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \
+  test7.byt test8.byt test9.byt testA.byt sieve.byt \
+  testio.byt testsocket.byt testwait.byt testsignal.byt testsignal2.byt \
+  testsieve.byt token1.byt token2.byt
+
+CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../../stdlib -I ../../unix
+
+include ../../../config/Makefile
+
+all: $(PROGS)
+
+clean:
+	rm -f *.cm* *.byt
+
+sorts.byt: sorts.ml
+	$(CAMLC) -o sorts.byt -I ../../graph threads.cma graphics.cma sorts.ml $(LIBS) $(X11_LINK)
+
+.SUFFIXES: .ml .byt
+
+.ml.byt:
+	$(CAMLC) -o $*.byt unix.cma threads.cma $*.ml $(LIBS)
+
+$(PROGS): ../threads.cma ../libthreads.a
diff --git a/otherlibs/threads/Tests/close.ml b/otherlibs/threads/Tests/close.ml
new file mode 100644
index 00000000..21ebb44a
--- /dev/null
+++ b/otherlibs/threads/Tests/close.ml
@@ -0,0 +1,14 @@
+let main () =
+  let (rd, wr) = Unix.pipe() in
+  Thread.create
+    (fun () ->
+      Thread.delay 3.0;
+      prerr_endline "closing fd...";
+      Unix.close rd)
+    ();
+  let buf = String.create 10 in
+  prerr_endline "reading...";
+  Unix.read rd buf 0 10;
+  prerr_endline "read returned"
+
+let _ = Unix.handle_unix_error main ()
diff --git a/otherlibs/threads/Tests/sieve.ml b/otherlibs/threads/Tests/sieve.ml
new file mode 100644
index 00000000..72e26566
--- /dev/null
+++ b/otherlibs/threads/Tests/sieve.ml
@@ -0,0 +1,33 @@
+open Printf
+open Thread
+
+let rec integers n ch =
+  Event.sync (Event.send ch n);
+  integers (n+1) ch
+
+let rec sieve n chin chout =
+  let m = Event.sync (Event.receive chin)
+  in if m mod n = 0
+     then sieve n chin chout
+     else Event.sync (Event.send chout m);
+          sieve n chin chout
+
+let rec print_primes ch max =
+  let n = Event.sync (Event.receive ch)
+  in if n > max
+     then ()
+     else begin
+            printf "%d\n" n; flush stdout;
+            let ch_after_n = Event.new_channel ()
+            in Thread.create (sieve n ch) ch_after_n;
+               print_primes ch_after_n max
+          end
+
+let go max =
+  let ch = Event.new_channel ()
+  in Thread.create (integers 2) ch;
+     print_primes ch max;;
+
+let _ = go 1000
+
+;;
diff --git a/otherlibs/threads/Tests/sorts.ml b/otherlibs/threads/Tests/sorts.ml
new file mode 100644
index 00000000..abc8dc1b
--- /dev/null
+++ b/otherlibs/threads/Tests/sorts.ml
@@ -0,0 +1,228 @@
+(* Animation of sorting algorithms. *)
+
+open Graphics
+
+(* Information on a given sorting process *)
+
+type graphic_context =
+  { array: int array;                   (* Data to sort *)
+    x0: int;                            (* X coordinate, lower left corner *)
+    y0: int;                            (* Y coordinate, lower left corner *)
+    width: int;                         (* Width in pixels *)
+    height: int;                        (* Height in pixels *)
+    nelts: int;                         (* Number of elements in the array *)
+    maxval: int;                        (* Max val in the array + 1 *)
+    rad: int                            (* Dimension of the rectangles *)
+  }
+
+(* Array assignment and exchange with screen update *)
+
+let screen_mutex = Mutex.create()
+
+let draw gc i v =
+  fill_rect (gc.x0 + (gc.width * i) / gc.nelts)
+            (gc.y0 + (gc.height * v) / gc.maxval)
+            gc.rad gc.rad
+
+let assign gc i v =
+  Mutex.lock screen_mutex;
+  set_color background; draw gc i gc.array.(i);
+  set_color foreground; draw gc i v;
+  gc.array.(i) <- v;
+  Mutex.unlock screen_mutex
+
+let exchange gc i j =
+  let val_i = gc.array.(i) in
+  assign gc i gc.array.(j);
+  assign gc j val_i
+
+(* Construction of a graphic context *)
+
+let initialize name array maxval x y w h =
+  let (_, label_height) = text_size name in
+  let rad = (w - 2) / (Array.length array) - 1 in
+  let gc =
+    { array = Array.copy array;
+      x0 = x + 1;                       (* Leave one pixel left for Y axis *)
+      y0 = y + 1;                       (* Leave one pixel below for X axis *)
+      width = w - 2;                    (* 1 pixel left, 1 pixel right *)
+      height = h - 1 - label_height - rad;
+      nelts = Array.length array;
+      maxval = maxval;
+      rad = rad } in
+  moveto (gc.x0 - 1) (gc.y0 + gc.height);
+  lineto (gc.x0 - 1) (gc.y0 - 1);
+  lineto (gc.x0 + gc.width) (gc.y0 - 1);
+  moveto (gc.x0 - 1) (gc.y0 + gc.height);
+  draw_string name;
+  for i = 0 to Array.length array - 1 do
+    draw gc i array.(i)
+  done;
+  gc
+
+(* Main animation function *)
+
+let display functs nelts maxval =
+  let a = Array.create nelts 0 in
+  for i = 0 to nelts - 1 do
+    a.(i) <- Random.int maxval
+  done;
+  let num_finished = ref 0 in
+  let lock_finished = Mutex.create() in
+  let cond_finished = Condition.create() in
+  for i = 0 to Array.length functs - 1 do
+    let (name, funct, x, y, w, h) = functs.(i) in
+    let gc = initialize name a maxval x y w h in
+    Thread.create
+      (fun () ->
+        funct gc;
+        Mutex.lock lock_finished;
+        incr num_finished;
+        Mutex.unlock lock_finished;
+        Condition.signal cond_finished)
+      ()
+  done;
+  Mutex.lock lock_finished;
+  while !num_finished < Array.length functs do
+    Condition.wait cond_finished lock_finished
+  done;
+  Mutex.unlock lock_finished;
+  read_key()
+
+(*****
+  let delay = ref 0 in
+  try
+    while true do
+      let gc = Queue.take q in
+        begin match gc.action with
+          Finished -> ()
+        | Pause f ->
+            gc.action <- f ();
+            for i = 0 to !delay do () done;
+            Queue.add gc q
+        end;
+      if key_pressed() then begin
+        match read_key() with
+          'q'|'Q' ->
+            raise Exit
+        | '0'..'9' as c ->
+            delay := (Char.code c - 48) * 500
+        | _ ->
+            ()
+      end
+    done
+  with Exit -> ()
+     | Queue.Empty -> read_key(); ()
+*****)
+
+(* The sorting functions. *)
+
+(* Bubble sort *)
+
+let bubble_sort gc =
+  let ordered = ref false in
+  while not !ordered do
+    ordered := true;
+    for i = 0 to Array.length gc.array - 2 do
+      if gc.array.(i+1) < gc.array.(i) then begin
+        exchange gc i (i+1);
+        ordered := false
+      end
+    done
+  done
+
+(* Insertion sort *)
+
+let insertion_sort gc =
+  for i = 1 to Array.length gc.array - 1 do
+    let val_i = gc.array.(i) in
+    let j = ref (i - 1) in
+    while !j >= 0 && val_i < gc.array.(!j) do
+      assign gc (!j + 1) gc.array.(!j);
+      decr j
+    done;
+    assign gc (!j + 1) val_i
+  done
+
+(* Selection sort *)
+
+let selection_sort gc =
+  for i = 0 to Array.length gc.array - 1 do
+    let min = ref i in
+    for j = i+1 to Array.length gc.array - 1 do
+      if gc.array.(j) < gc.array.(!min) then min := j
+    done;
+    exchange gc i !min
+  done
+
+(* Quick sort *)
+
+let quick_sort gc =
+  let rec quick lo hi =
+    if lo < hi then begin
+      let i = ref lo in
+      let j = ref hi in
+      let pivot = gc.array.(hi) in
+      while !i < !j do
+        while !i < hi && gc.array.(!i) <= pivot do incr i done;
+        while !j > lo && gc.array.(!j) >= pivot do decr j done;
+        if !i < !j then exchange gc !i !j
+      done;
+      exchange gc !i hi;
+      quick lo (!i-1);
+      quick (!i+1) hi
+    end
+  in quick 0 (Array.length gc.array - 1)
+
+(* Merge sort *)
+
+let merge_sort gc =
+  let rec merge i l1 l2 =
+    match (l1, l2) with
+      ([], []) ->
+        ()
+    | ([], v2::r2) ->
+        assign gc i v2; merge (i+1) l1 r2
+    | (v1::r1, []) ->
+        assign gc i v1; merge (i+1) r1 l2
+    | (v1::r1, v2::r2) ->
+        if v1 < v2
+        then begin assign gc i v1; merge (i+1) r1 l2 end
+        else begin assign gc i v2; merge (i+1) l1 r2 end in
+  let rec msort start len =
+    if len < 2 then () else begin
+      let m = len / 2 in
+      msort start m;
+      msort (start+m) (len-m);
+      merge start
+            (Array.to_list (Array.sub gc.array start m))
+            (Array.to_list (Array.sub gc.array (start+m) (len-m)))
+    end in
+  msort 0 (Array.length gc.array)
+
+(* Main program *)
+
+let animate() =
+  open_graph "";
+  moveto 0 0; draw_string "Press a key to start...";
+  let seed = ref 0 in
+  while not (key_pressed()) do incr seed done;
+  read_key();
+  Random.init !seed;
+  clear_graph();
+  let prompt = "0: fastest ... 9: slowest, press 'q' to quit" in
+  moveto 0 0; draw_string prompt;
+  let (_, h) = text_size prompt in
+  let sx = size_x() / 2 and sy = (size_y() - h) / 3 in
+  display [| "Bubble", bubble_sort, 0, h, sx, sy;
+             "Insertion", insertion_sort, 0, h+sy, sx, sy;
+             "Selection", selection_sort, 0, h+2*sy, sx, sy;
+             "Quicksort", quick_sort, sx, h, sx, sy;
+             (** "Heapsort", heap_sort, sx, h+sy, sx, sy; **)
+             "Mergesort", merge_sort, sx, h+2*sy, sx, sy |]
+          100 1000;
+  close_graph()
+
+let _ = if !Sys.interactive then () else begin animate(); exit 0 end
+
+;;
diff --git a/otherlibs/threads/Tests/test1.ml b/otherlibs/threads/Tests/test1.ml
new file mode 100644
index 00000000..9d2cf0a5
--- /dev/null
+++ b/otherlibs/threads/Tests/test1.ml
@@ -0,0 +1,57 @@
+(* Classic producer-consumer *)
+
+type 'a prodcons =
+  { buffer: 'a array;
+    lock: Mutex.t;
+    mutable readpos: int;
+    mutable writepos: int;
+    notempty: Condition.t;
+    notfull: Condition.t }
+
+let create size init =
+  { buffer = Array.create size init;
+    lock = Mutex.create();
+    readpos = 0;
+    writepos = 0;
+    notempty = Condition.create();
+    notfull = Condition.create() }
+
+let put p data =
+  Mutex.lock p.lock;
+  while (p.writepos + 1) mod Array.length p.buffer = p.readpos do
+    Condition.wait p.notfull p.lock
+  done;
+  p.buffer.(p.writepos) <- data;
+  p.writepos <- (p.writepos + 1) mod Array.length p.buffer;
+  Condition.signal p.notempty;
+  Mutex.unlock p.lock
+
+let get p =
+  Mutex.lock p.lock;
+  while p.writepos = p.readpos do
+    Condition.wait p.notempty p.lock
+  done;
+  let data = p.buffer.(p.readpos) in
+  p.readpos <- (p.readpos + 1) mod Array.length p.buffer;
+  Condition.signal p.notfull;
+  Mutex.unlock p.lock;
+  data
+
+(* Test *)
+
+let buff = create 20 0
+
+let rec produce n =
+  print_int n; print_string "-->"; print_newline();
+  put buff n;
+  if n < 10000 then produce (n+1)
+
+let rec consume () =
+  let n = get buff in
+  print_string "-->"; print_int n; print_newline();
+  if n < 10000 then consume ()
+
+let t1 = Thread.create produce 0
+let _ = consume ()
+
+;;
diff --git a/otherlibs/threads/Tests/test2.ml b/otherlibs/threads/Tests/test2.ml
new file mode 100644
index 00000000..926f0907
--- /dev/null
+++ b/otherlibs/threads/Tests/test2.ml
@@ -0,0 +1,15 @@
+let yield = ref false
+
+let print_message c =
+  for i = 1 to 10000 do
+    print_char c; flush stdout;
+    if !yield then Thread.yield()
+  done
+
+let _ = yield := (Array.length Sys.argv > 1)
+let t1 = Thread.create print_message 'a'
+let t2 = Thread.create print_message 'b'
+let _ = Thread.join t1
+let _ = Thread.join t2
+
+;;
diff --git a/otherlibs/threads/Tests/test3.ml b/otherlibs/threads/Tests/test3.ml
new file mode 100644
index 00000000..c6df3326
--- /dev/null
+++ b/otherlibs/threads/Tests/test3.ml
@@ -0,0 +1,8 @@
+let print_message delay c =
+  while true do
+    print_char c; flush stdout; Thread.delay delay
+  done
+
+let _ =
+  Thread.create (print_message 0.6666666666) 'a';
+  print_message 1.0 'b'
diff --git a/otherlibs/threads/Tests/test4.ml b/otherlibs/threads/Tests/test4.ml
new file mode 100644
index 00000000..ff84961b
--- /dev/null
+++ b/otherlibs/threads/Tests/test4.ml
@@ -0,0 +1,13 @@
+let rec fib n = if n <= 2 then 1 else fib(n-1) + fib(n-2)
+
+let fibtask n =
+  while true do
+    print_int(fib n); print_newline()
+  done
+
+let _ =
+  Thread.create fibtask 28;
+  while true do
+    let l = read_line () in
+    print_string ">> "; print_string l; print_newline()
+  done
diff --git a/otherlibs/threads/Tests/test5.ml b/otherlibs/threads/Tests/test5.ml
new file mode 100644
index 00000000..2baffe02
--- /dev/null
+++ b/otherlibs/threads/Tests/test5.ml
@@ -0,0 +1,21 @@
+open Event
+
+let ch = (new_channel() : string channel)
+
+let rec sender msg =
+  sync (send ch msg);
+  sender msg
+
+let rec receiver name =
+  print_string (name ^ ": " ^ sync (receive ch) ^ "\n");
+  flush stdout;
+  receiver name
+
+let _ =
+  Thread.create sender "hello";
+  Thread.create sender "world";
+  Thread.create receiver "A";
+  receiver "B";
+  exit 0
+
+
diff --git a/otherlibs/threads/Tests/test6.ml b/otherlibs/threads/Tests/test6.ml
new file mode 100644
index 00000000..b846858e
--- /dev/null
+++ b/otherlibs/threads/Tests/test6.ml
@@ -0,0 +1,17 @@
+open Event
+
+let ch = (new_channel() : string channel)
+
+let rec f tag msg =
+  select [
+    send ch msg;
+    wrap (receive ch) (fun x -> print_string(tag ^ ": " ^ x); print_newline())
+  ];
+  f tag msg
+
+let _ =
+  Thread.create (f "A") "hello";
+  f "B" "world";
+  exit 0
+
+
diff --git a/otherlibs/threads/Tests/test7.ml b/otherlibs/threads/Tests/test7.ml
new file mode 100644
index 00000000..e6bd1d81
--- /dev/null
+++ b/otherlibs/threads/Tests/test7.ml
@@ -0,0 +1,28 @@
+open Event
+
+let add_ch = new_channel()
+let sub_ch = new_channel()
+let read_ch = new_channel()
+
+let rec accu n =
+  select [
+    wrap (receive add_ch) (fun x -> accu (n+x));
+    wrap (receive sub_ch) (fun x -> accu (n-x));
+    wrap (send read_ch n) (fun () -> accu n)
+  ]
+
+let rec sender chan value =
+  sync(send chan value); sender chan value
+
+let read () =
+  print_int(sync(receive read_ch)); print_newline()
+
+let main () =
+  Thread.create accu 0;
+  Thread.create (sender add_ch) 1;
+  Thread.create (sender sub_ch) 1;
+  while true do read() done
+
+let _ = Printexc.catch main ()
+
+  
diff --git a/otherlibs/threads/Tests/test8.ml b/otherlibs/threads/Tests/test8.ml
new file mode 100644
index 00000000..cc587b0a
--- /dev/null
+++ b/otherlibs/threads/Tests/test8.ml
@@ -0,0 +1,46 @@
+open Event
+
+type 'a buffer_channel = { input: 'a channel; output: 'a channel }
+
+let new_buffer_channel() =
+  let ic = new_channel() in
+  let oc = new_channel() in
+  let buff = Queue.create() in
+  let rec buffer_process front rear =
+    match (front, rear) with
+      ([], []) -> buffer_process [sync(receive ic)] []
+    | (hd::tl, _) ->
+        select [
+          wrap (receive ic) (fun x -> buffer_process front (x::rear));
+          wrap (send oc hd) (fun () -> buffer_process tl rear)
+        ]
+    | ([], _) -> buffer_process (List.rev rear) [] in
+  Thread.create (buffer_process []) [];
+  { input = ic; output = oc }
+
+let buffer_send bc data =
+  sync(send bc.input data)
+
+let buffer_receive bc =
+  receive bc.output
+
+(* Test *)
+
+let box = new_buffer_channel()
+let ch = new_channel()
+
+let f () =
+  buffer_send box "un";
+  buffer_send box "deux";
+  sync (send ch 3)
+
+let g () =
+  print_int (sync(receive ch)); print_newline();
+  print_string (sync(buffer_receive box)); print_newline();
+  print_string (sync(buffer_receive box)); print_newline()
+
+let _ =
+  Thread.create f ();
+  g()
+
+
diff --git a/otherlibs/threads/Tests/test9.ml b/otherlibs/threads/Tests/test9.ml
new file mode 100644
index 00000000..1f80beb8
--- /dev/null
+++ b/otherlibs/threads/Tests/test9.ml
@@ -0,0 +1,26 @@
+open Event
+
+type 'a swap_chan = ('a * 'a channel) channel
+
+let swap msg_out ch =
+  guard (fun () ->
+    let ic = new_channel() in
+    choose [
+      wrap (receive ch) (fun (msg_in, oc) -> sync (send oc msg_out); msg_in);
+      wrap (send ch (msg_out, ic)) (fun () -> sync (receive ic))
+    ])
+
+let ch = new_channel()
+
+let f () =
+  let res = sync (swap "F" ch) in
+  print_string "f "; print_string res; print_newline()
+
+let g () =
+  let res = sync (swap "G" ch) in
+  print_string "g "; print_string res; print_newline()
+
+let _ =
+  let id = Thread.create f () in
+  g ();
+  Thread.join id
diff --git a/otherlibs/threads/Tests/testA.ml b/otherlibs/threads/Tests/testA.ml
new file mode 100644
index 00000000..b1999b87
--- /dev/null
+++ b/otherlibs/threads/Tests/testA.ml
@@ -0,0 +1,24 @@
+let private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t)
+let private_data_lock = Mutex.create()
+
+let set_private_data data =
+  Mutex.lock private_data_lock;
+  Hashtbl.add private_data (Thread.self()) data;
+  Mutex.unlock private_data_lock
+
+let get_private_data () =
+  Hashtbl.find private_data (Thread.self())
+
+let process id data =
+  set_private_data data;
+  print_int id; print_string " --> "; print_string(get_private_data());
+  print_newline()
+
+let _ =
+  let t1 = Thread.create (process 1) "un" in
+  let t2 = Thread.create (process 2) "deux" in
+  let t3 = Thread.create (process 3) "trois" in
+  let t4 = Thread.create (process 4) "quatre" in
+  let t5 = Thread.create (process 5) "cinq" in
+  List.iter Thread.join [t1;t2;t3;t4;t5]
+
diff --git a/otherlibs/threads/Tests/testexit.ml b/otherlibs/threads/Tests/testexit.ml
new file mode 100644
index 00000000..2045c25a
--- /dev/null
+++ b/otherlibs/threads/Tests/testexit.ml
@@ -0,0 +1,22 @@
+(* Test Thread.exit *)
+
+let somethread (name, limit, last) =
+  let counter = ref 0 in
+  while true do
+    incr counter;
+    if !counter >= limit then begin
+      print_string (name ^ " exiting\n");
+      flush stdout;
+      if last then exit 0 else Thread.exit()
+    end;
+    print_string (name ^ ": " ^ string_of_int !counter ^ "\n");
+    flush stdout;
+    Thread.delay 0.5
+  done
+
+let _ =
+  let _ = Thread.create somethread ("A", 5, false) in
+  let _ = Thread.create somethread ("B", 8, false) in
+  let _ = Thread.create somethread ("C", 11, true) in
+  somethread ("Main", 3, false)
+
diff --git a/otherlibs/threads/Tests/testio.ml b/otherlibs/threads/Tests/testio.ml
new file mode 100644
index 00000000..3ed08a88
--- /dev/null
+++ b/otherlibs/threads/Tests/testio.ml
@@ -0,0 +1,119 @@
+(* Test a file copy function *)
+
+let test msg producer consumer src dst =
+  print_string msg; print_newline();
+  let ic = open_in_bin src in
+  let oc = open_out_bin dst in
+  let (in_fd, out_fd) = Unix.pipe() in
+  let ipipe = Unix.in_channel_of_descr in_fd in
+  let opipe = Unix.out_channel_of_descr out_fd in
+  let prod = Thread.create producer (ic, opipe) in
+  let cons = Thread.create consumer (ipipe, oc) in
+  Thread.join prod;
+  Thread.join cons;
+  if Unix.system ("cmp " ^ src ^ " " ^ dst) = Unix.WEXITED 0
+  then print_string "passed"
+  else print_string "FAILED";
+  print_newline()
+
+(* File copy with constant-sized chunks *)
+
+let copy_file sz (ic, oc) =
+  let buffer = String.create sz in
+  let rec copy () =
+    let n = input ic buffer 0 sz in
+    if n = 0 then () else begin
+      output oc buffer 0 n;
+      copy ()
+    end in
+  copy();
+  close_in ic;
+  close_out oc
+
+(* File copy with random-sized chunks *)
+
+let copy_random sz (ic, oc) =
+  let buffer = String.create sz in
+  let rec copy () =
+    let s = 1 + Random.int sz in
+    let n = input ic buffer 0 s in
+    if n = 0 then () else begin
+      output oc buffer 0 n;
+      copy ()
+    end in
+  copy();
+  close_in ic;
+  close_out oc
+
+(* File copy line per line *)
+
+let copy_line (ic, oc) =
+  try
+    while true do
+      output_string oc (input_line ic); output_char oc '\n'
+    done
+  with End_of_file ->
+    close_in ic;
+    close_out oc
+
+(* Create long lines of text *)
+
+let make_lines ofile =
+  let oc = open_out ofile in
+  for i = 1 to 256 do
+    output_string oc (String.make (i*16) '.'); output_char oc '\n'
+  done;
+  close_out oc
+
+(* Test input_line on truncated lines *)
+
+let test_trunc_line ofile =
+  print_string "truncated line"; print_newline();
+  let oc = open_out ofile in
+  output_string oc "A line without newline!";
+  close_out oc;
+  try
+    let ic = open_in ofile in
+    let s = input_line ic in
+    close_in ic;
+    if s = "A line without newline!"
+    then print_string "passed"
+    else print_string "FAILED";
+    print_newline()
+  with End_of_file ->
+    print_string "FAILED"; print_newline()  
+
+(* The test *)
+
+let main() =
+  let ifile = Sys.argv.(1) in
+  let ofile = "/tmp/testio" in
+  test "256-byte chunks, 256-byte chunks"
+       (copy_file 256) (copy_file 256) ifile ofile;
+  test "4096-byte chunks, 4096-byte chunks"
+       (copy_file 4096) (copy_file 4096) ifile ofile;
+  test "65536-byte chunks, 65536-byte chunks"
+       (copy_file 65536) (copy_file 65536) ifile ofile;
+  test "256-byte chunks, 4096-byte chunks"
+       (copy_file 256) (copy_file 4096) ifile ofile;
+  test "4096-byte chunks, 256-byte chunks"
+       (copy_file 4096) (copy_file 256) ifile ofile;
+  test "4096-byte chunks, 65536-byte chunks"
+       (copy_file 4096) (copy_file 65536) ifile ofile;
+  test "263-byte chunks, 4011-byte chunks"
+       (copy_file 263) (copy_file 4011) ifile ofile;
+  test "613-byte chunks, 1027-byte chunks"
+       (copy_file 613) (copy_file 1027) ifile ofile;
+  test "0...8192 byte chunks"
+       (copy_random 8192) (copy_random 8192) ifile ofile;
+  test "line per line, short lines"
+       copy_line copy_line "/etc/hosts" ofile;
+  make_lines "/tmp/lines";
+  test "line per line, short and long lines"
+       copy_line copy_line "/tmp/lines" ofile;
+  test_trunc_line ofile;
+  Sys.remove "/tmp/lines";
+  Sys.remove ofile;
+  exit 0
+
+let _ = Unix.handle_unix_error main (); exit 0
diff --git a/otherlibs/threads/Tests/testsieve.ml b/otherlibs/threads/Tests/testsieve.ml
new file mode 100644
index 00000000..6079d8a8
--- /dev/null
+++ b/otherlibs/threads/Tests/testsieve.ml
@@ -0,0 +1,42 @@
+let sieve primes=
+  Event.sync (Event.send primes 0);
+  Event.sync (Event.send primes 1);
+  Event.sync (Event.send primes 2);
+  let integers = Event.new_channel () in
+  let rec enumerate n=
+    Event.sync (Event.send integers n);
+    enumerate (n + 2)
+  and filter inpout =
+    let n = Event.sync (Event.receive inpout)
+    (* On prepare le terrain pour l'appel recursif *)
+    and output = Event.new_channel () in
+    (* Celui qui etait en tete du crible est premier *)
+    Event.sync (Event.send primes n);
+    Thread.create filter output;
+    (* On elimine de la sortie ceux qui sont des multiples de n *)
+    while true do
+        let m = Event.sync (Event.receive inpout) in
+        (* print_int n; print_string ": "; print_int m; print_newline(); *)
+        if (m mod n) = 0
+        then ()
+        else ((Event.sync (Event.send output m));())
+      done in
+  Thread.create filter integers;
+  Thread.create enumerate 3
+
+let premiers = Event.new_channel ()
+
+let main _ =
+  Thread.create sieve premiers;
+  while true do
+    for i = 1 to 100 do
+      let n = Event.sync (Event.receive premiers) in
+      print_int n; print_newline()
+    done;
+    exit 0
+    done
+
+
+let _ =
+  try main ()
+  with _ -> exit 0;;
diff --git a/otherlibs/threads/Tests/testsignal.ml b/otherlibs/threads/Tests/testsignal.ml
new file mode 100644
index 00000000..7781f337
--- /dev/null
+++ b/otherlibs/threads/Tests/testsignal.ml
@@ -0,0 +1,13 @@
+let sighandler _ =
+  print_string "Got ctrl-C, exiting..."; print_newline();
+  exit 0
+
+let print_message delay c =
+  while true do
+    print_char c; flush stdout; Thread.delay delay
+  done
+
+let _ =
+  Sys.signal Sys.sigint (Sys.Signal_handle sighandler);
+  Thread.create (print_message 0.6666666666) 'a';
+  print_message 1.0 'b'
diff --git a/otherlibs/threads/Tests/testsignal2.ml b/otherlibs/threads/Tests/testsignal2.ml
new file mode 100644
index 00000000..1f7fc0f9
--- /dev/null
+++ b/otherlibs/threads/Tests/testsignal2.ml
@@ -0,0 +1,10 @@
+let print_message delay c =
+  while true do
+    print_char c; flush stdout; Thread.delay delay
+  done
+
+let _ =
+  let th1 = Thread.create (print_message 0.6666666666) 'a' in
+  let th2 = Thread.create (print_message 1.0) 'b' in
+  let s = Thread.wait_signal [Sys.sigint; Sys.sigterm] in
+  Printf.printf "Got signal %d, exiting...\n" s
diff --git a/otherlibs/threads/Tests/testsocket.ml b/otherlibs/threads/Tests/testsocket.ml
new file mode 100644
index 00000000..d0f14cbf
--- /dev/null
+++ b/otherlibs/threads/Tests/testsocket.ml
@@ -0,0 +1,31 @@
+open Unix
+
+let engine number address =
+  print_int number; print_string "> connecting"; print_newline();
+  let (ic, oc) = open_connection (ADDR_INET(address, 80)) in
+  print_int number; print_string "> connected"; print_newline();
+  output_string oc "GET / HTTP1.0\r\n\r\n"; flush oc;
+  try
+    while true do
+      let s = input_line ic in
+      print_int number; print_string ">"; print_string s; print_newline()
+    done
+  with End_of_file ->
+    close_out oc
+
+let main() =
+  let addresses = Array.create (Array.length Sys.argv - 1) inet_addr_any in
+  for i = 1 to Array.length Sys.argv - 1 do
+    addresses.(i - 1) <- (gethostbyname Sys.argv.(i)).h_addr_list.(0)
+  done;
+  let processes = Array.create (Array.length addresses) (Thread.self()) in
+  for i = 0 to Array.length addresses - 1 do
+    processes.(i) <- Thread.create (engine i) addresses.(i)
+  done;
+  for i = 0 to Array.length processes - 1 do
+    Thread.join processes.(i)
+  done
+
+let _ = Printexc.catch main (); exit 0
+
+    
diff --git a/otherlibs/threads/Tests/token1.ml b/otherlibs/threads/Tests/token1.ml
new file mode 100644
index 00000000..fb0ddb2d
--- /dev/null
+++ b/otherlibs/threads/Tests/token1.ml
@@ -0,0 +1,36 @@
+(* Performance test for mutexes and conditions *)
+
+let mut = Mutex.create()
+
+let niter = ref 0
+
+let token = ref 0
+
+let process (n, conds, nprocs) =
+  while true do
+    Mutex.lock mut;
+    while !token <> n do 
+      (* Printf.printf "Thread %d waiting (token = %d)\n" n !token; *)
+      Condition.wait conds.(n) mut
+    done;
+    (* Printf.printf "Thread %d got token %d\n" n !token; *)
+    incr token;
+    if !token >= nprocs then token := 0;
+    if n = 0 then begin
+      decr niter;
+      if !niter <= 0 then exit 0
+    end;
+    Condition.signal conds.(!token);
+    Mutex.unlock mut
+  done
+
+let main() =
+  let nprocs = int_of_string Sys.argv.(1) in
+  let iter = int_of_string Sys.argv.(2) in
+  let conds = Array.create nprocs (Condition.create()) in
+  for i = 1 to nprocs - 1 do conds.(i) <- Condition.create() done;
+  niter := iter;
+  for i = 0 to nprocs - 1 do Thread.create process (i, conds, nprocs) done;
+  Thread.delay 3600.
+
+let _ = main()
diff --git a/otherlibs/threads/Tests/token2.ml b/otherlibs/threads/Tests/token2.ml
new file mode 100644
index 00000000..32b897dd
--- /dev/null
+++ b/otherlibs/threads/Tests/token2.ml
@@ -0,0 +1,36 @@
+(* Performance test for I/O scheduling *)
+
+let mut = Mutex.create()
+
+let niter = ref 0
+
+let token = ref 0
+
+let process (n, ins, outs, nprocs) =
+  let buf = String.create 1 in
+  while true do
+    Unix.read ins.(n) buf 0 1;
+    (* Printf.printf "Thread %d got the token\n" n; *)
+    if n = 0 then begin
+      decr niter;
+      if !niter <= 0 then exit 0
+    end;
+    let next = if n + 1 >= nprocs then 0 else n + 1 in
+    (* Printf.printf "Thread %d sending token to thread %d\n" n next; *)
+    Unix.write outs.(next) buf 0 1
+  done
+
+let main() =
+  let nprocs = int_of_string Sys.argv.(1) in
+  let iter = int_of_string Sys.argv.(2) in
+  let ins = Array.create nprocs Unix.stdin in
+  let outs = Array.create nprocs Unix.stdout in
+  for n = 0 to nprocs - 1 do
+    let (i, o) = Unix.pipe() in ins.(n) <- i; outs.(n) <- o
+  done;
+  niter := iter;
+  for i = 0 to nprocs - 1 do Thread.create process (i, ins, outs, nprocs) done;
+  Unix.write outs.(0) "X" 0 1;
+  Thread.delay 3600.
+
+let _ = main()
diff --git a/otherlibs/threads/Tests/torture.ml b/otherlibs/threads/Tests/torture.ml
new file mode 100644
index 00000000..b52766dc
--- /dev/null
+++ b/otherlibs/threads/Tests/torture.ml
@@ -0,0 +1,46 @@
+(* Torture test - lots of GC *)
+
+let gc_thread () =
+  while true do
+(*    print_string "gc"; print_newline(); *)
+    Gc.minor();
+    Thread.yield()
+  done
+
+let stdin_thread () =
+  while true do
+    print_string "> "; flush stdout;
+    let s = read_line() in
+    print_string ">>> "; print_string s; print_newline()
+  done
+
+let writer_thread (oc, size) =
+  while true do
+(*    print_string "writer "; print_int size; print_newline(); *)
+    let buff = String.make size 'a' in
+    Unix.write oc buff 0 size
+  done
+
+let reader_thread (ic, size) =
+  while true do
+(*    print_string "reader "; print_int size; print_newline(); *)
+    let buff = String.create size in
+    let n = Unix.read ic buff 0 size in
+(*    print_string "reader "; print_int n; print_newline(); *)
+    for i = 0 to n-1 do
+      if buff.[i] <> 'a' then prerr_endline "error in reader_thread"
+    done
+  done
+
+let main() =
+  Thread.create gc_thread ();
+  let (out1, in1) = Unix.pipe() in
+  Thread.create writer_thread (in1, 4096);
+  Thread.create reader_thread (out1, 4096);
+  let (out2, in2) = Unix.pipe() in
+  Thread.create writer_thread (in2, 16);
+  Thread.create reader_thread (out2, 16);
+  stdin_thread()
+
+let _ = main()
+
diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml
index 9674af61..59f4cff5 100644
--- a/otherlibs/threads/marshal.ml
+++ b/otherlibs/threads/marshal.ml
@@ -11,21 +11,21 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: marshal.ml,v 1.7 2002/10/26 13:33:43 xleroy Exp $ *)
+(* $Id: marshal.ml,v 1.9 2004/05/27 15:28:05 doligez Exp $ *)
 
 type extern_flags =
     No_sharing
   | Closures
 
 external to_string: 'a -> extern_flags list -> string
-    = "output_value_to_string"
+    = "caml_output_value_to_string"
 
 let to_channel chan v flags =
   output_string chan (to_string v flags)
 
 external to_buffer_unsafe:
       string -> int -> int -> 'a -> extern_flags list -> int
-    = "output_value_to_buffer"
+    = "caml_output_value_to_buffer"
 
 let to_buffer buff ofs len v flags =
   if ofs < 0 || len < 0 || ofs + len > String.length buff
@@ -34,8 +34,9 @@ let to_buffer buff ofs len v flags =
 
 let to_buffer' ~buf ~pos ~len v ~mode = to_buffer buf pos len v mode
 
-external from_string_unsafe: string -> int -> 'a = "input_value_from_string"
-external data_size_unsafe: string -> int -> int = "marshal_data_size"
+external from_string_unsafe: string -> int -> 'a
+         = "caml_input_value_from_string"
+external data_size_unsafe: string -> int -> int = "caml_marshal_data_size"
 
 let header_size = 20
 let data_size buff ofs =
diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
index f45f1af6..6e8bd547 100644
--- a/otherlibs/threads/pervasives.ml
+++ b/otherlibs/threads/pervasives.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: pervasives.ml,v 1.44 2003/07/29 09:09:33 xleroy Exp $ *)
+(* $Id: pervasives.ml,v 1.48.4.1 2004/06/22 12:13:46 xleroy Exp $ *)
 
 (* Same as ../../stdlib/pervasives.ml, except that I/O functions have
    been redefined to not block the whole process, but only the calling
@@ -85,65 +85,60 @@ external (+.) : float -> float -> float = "%addfloat"
 external (-.) : float -> float -> float = "%subfloat"
 external ( *. ) : float -> float -> float = "%mulfloat"
 external (/.) : float -> float -> float = "%divfloat"
-external ( ** ) : float -> float -> float = "power_float" "pow" "float"
-external exp : float -> float = "exp_float" "exp" "float"
-external acos : float -> float = "acos_float" "acos" "float"
-external asin : float -> float = "asin_float" "asin" "float"
-external atan : float -> float = "atan_float" "atan" "float"
-external atan2 : float -> float -> float = "atan2_float" "atan2" "float"
-external cos : float -> float = "cos_float" "cos" "float"
-external cosh : float -> float = "cosh_float" "cosh" "float"
-external log : float -> float = "log_float" "log" "float"
-external log10 : float -> float = "log10_float" "log10" "float"
-external sin : float -> float = "sin_float" "sin" "float"
-external sinh : float -> float = "sinh_float" "sinh" "float"
-external sqrt : float -> float = "sqrt_float" "sqrt" "float"
-external tan : float -> float = "tan_float" "tan" "float"
-external tanh : float -> float = "tanh_float" "tanh" "float"
-external ceil : float -> float = "ceil_float" "ceil" "float"
-external floor : float -> float = "floor_float" "floor" "float"
+external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float"
+external exp : float -> float = "caml_exp_float" "exp" "float"
+external acos : float -> float = "caml_acos_float" "acos" "float"
+external asin : float -> float = "caml_asin_float" "asin" "float"
+external atan : float -> float = "caml_atan_float" "atan" "float"
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
+external cos : float -> float = "caml_cos_float" "cos" "float"
+external cosh : float -> float = "caml_cosh_float" "cosh" "float"
+external log : float -> float = "caml_log_float" "log" "float"
+external log10 : float -> float = "caml_log10_float" "log10" "float"
+external sin : float -> float = "caml_sin_float" "sin" "float"
+external sinh : float -> float = "caml_sinh_float" "sinh" "float"
+external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float"
+external tan : float -> float = "caml_tan_float" "tan" "float"
+external tanh : float -> float = "caml_tanh_float" "tanh" "float"
+external ceil : float -> float = "caml_ceil_float" "ceil" "float"
+external floor : float -> float = "caml_floor_float" "floor" "float"
 external abs_float : float -> float = "%absfloat"
-external mod_float : float -> float -> float = "fmod_float" "fmod" "float"
-external frexp : float -> float * int = "frexp_float"
-external ldexp : float -> int -> float = "ldexp_float"
-external modf : float -> float * float = "modf_float"
+external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
+external frexp : float -> float * int = "caml_frexp_float"
+external ldexp : float -> int -> float = "caml_ldexp_float"
+external modf : float -> float * float = "caml_modf_float"
 external float : int -> float = "%floatofint"
 external float_of_int : int -> float = "%floatofint"
 external truncate : float -> int = "%intoffloat"
 external int_of_float : float -> int = "%intoffloat"
-external float_of_bytes : string -> float = "float_of_bytes"
+external float_of_bits : int64 -> float = "caml_int64_float_of_bits"
 let infinity =
-  float_of_bytes "\127\240\000\000\000\000\000\000"
-              (* 0x7F F0 00 00 00 00 00 00 *)
+  float_of_bits 0x7F_F0_00_00_00_00_00_00L
 let neg_infinity =
-  float_of_bytes "\255\240\000\000\000\000\000\000"
-              (* 0xFF F0 00 00 00 00 00 00 *)
+  float_of_bits 0xFF_F0_00_00_00_00_00_00L
 let nan =
-  float_of_bytes "\127\240\000\000\000\000\000\001"
-              (* 0x7F F0 00 00 00 00 00 01 *)
+  float_of_bits 0x7F_F0_00_00_00_00_00_01L
 let max_float =
-  float_of_bytes "\127\239\255\255\255\255\255\255"
-              (* 0x7f ef ff ff ff ff ff ff *)
+  float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL
 let min_float =
-  float_of_bytes "\000\016\000\000\000\000\000\000"
-              (* 0x00 10 00 00 00 00 00 00 *)
+  float_of_bits 0x00_10_00_00_00_00_00_00L
 let epsilon_float =
-  float_of_bytes "\060\176\000\000\000\000\000\000"
-              (* 0x3c b0 00 00 00 00 00 00 *)
+  float_of_bits 0x3C_B0_00_00_00_00_00_00L
+
 type fpclass =
     FP_normal
   | FP_subnormal
   | FP_zero
   | FP_infinite
   | FP_nan
-external classify_float: float -> fpclass = "classify_float"
+external classify_float: float -> fpclass = "caml_classify_float"
 
 (* String operations -- more in module String *)
 
 external string_length : string -> int = "%string_length"
-external string_create: int -> string = "create_string"
+external string_create: int -> string = "caml_create_string"
 external string_blit : string -> int -> string -> int -> int -> unit
-                     = "blit_string" "noalloc"
+                     = "caml_blit_string" "noalloc"
 
 let (^) s1 s2 =
   let l1 = string_length s1 and l2 = string_length s2 in
@@ -179,8 +174,8 @@ external decr: int ref -> unit = "%decr"
 
 (* String conversion functions *)
 
-external format_int: string -> int -> string = "format_int"
-external format_float: string -> float -> string = "format_float"
+external format_int: string -> int -> string = "caml_format_int"
+external format_float: string -> float -> string = "caml_format_float"
 
 let string_of_bool b =
   if b then "true" else "false"
@@ -192,7 +187,7 @@ let bool_of_string = function
 let string_of_int n =
   format_int "%d" n
 
-external int_of_string : string -> int = "int_of_string"
+external int_of_string : string -> int = "caml_int_of_string"
 
 let valid_float_lexem s =
   let l = string_length s in
@@ -207,7 +202,7 @@ let valid_float_lexem s =
 
 let string_of_float f = valid_float_lexem (format_float "%.12g" f);;
 
-external float_of_string : string -> float = "float_of_string"
+external float_of_string : string -> float = "caml_float_of_string"
 
 (* List operations -- more in module List *)
 
@@ -221,8 +216,8 @@ let rec (@) l1 l2 =
 type in_channel
 type out_channel
 
-external open_descriptor_out: int -> out_channel = "caml_open_descriptor_out"
-external open_descriptor_in: int -> in_channel = "caml_open_descriptor_in"
+external open_descriptor_out: int -> out_channel = "caml_ml_open_descriptor_out"
+external open_descriptor_in: int -> in_channel = "caml_ml_open_descriptor_in"
 
 let stdin = open_descriptor_in 0
 let stdout = open_descriptor_out 1
@@ -238,8 +233,10 @@ let thread_wait_write fd = thread_wait_write_prim fd
 
 external inchan_ready : in_channel -> bool = "thread_inchan_ready"
 external outchan_ready : out_channel -> int -> bool = "thread_outchan_ready"
-external descr_inchan : in_channel -> Unix.file_descr = "channel_descriptor"
-external descr_outchan : out_channel -> Unix.file_descr = "channel_descriptor"
+external descr_inchan : in_channel -> Unix.file_descr
+                      = "caml_channel_descriptor"
+external descr_outchan : out_channel -> Unix.file_descr
+                       = "caml_channel_descriptor"
 
 let wait_inchan ic =
   if not (inchan_ready ic) then thread_wait_read(descr_inchan ic)
@@ -254,7 +251,7 @@ type open_flag =
   | Open_creat | Open_trunc | Open_excl
   | Open_binary | Open_text | Open_nonblock
 
-external open_desc: string -> open_flag list -> int -> int = "sys_open"
+external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
 
 let open_out_gen mode perm name =
   open_descriptor_out(open_desc name mode perm)
@@ -265,7 +262,7 @@ let open_out name =
 let open_out_bin name =
   open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
 
-external flush_partial : out_channel -> bool = "caml_flush_partial"
+external flush_partial : out_channel -> bool = "caml_ml_flush_partial"
 
 let rec flush oc =
   let success =
@@ -276,7 +273,7 @@ let rec flush oc =
   if success then () else flush oc
 
 external out_channels_list : unit -> out_channel list 
-                           = "caml_out_channels_list"
+                           = "caml_ml_out_channels_list"
 
 let flush_all () = 
   let rec iter = function
@@ -291,7 +288,7 @@ let flush_all () =
   in iter (out_channels_list ())
 
 external unsafe_output_partial : out_channel -> string -> int -> int -> int
-                        = "caml_output_partial"
+                        = "caml_ml_output_partial"
 
 let rec unsafe_output oc buf pos len =
   if len > 0 then begin
@@ -304,8 +301,9 @@ let rec unsafe_output oc buf pos len =
   end
 
 external output_char_blocking : out_channel -> char -> unit 
-                              = "caml_output_char"
-external output_byte_blocking : out_channel -> int -> unit = "caml_output_char"
+                              = "caml_ml_output_char"
+external output_byte_blocking : out_channel -> int -> unit
+                              = "caml_ml_output_char"
 
 let rec output_char oc c =
   try
@@ -336,24 +334,24 @@ let output_binary_int oc n =
   output_byte oc n
 
 external marshal_to_string : 'a -> unit list -> string 
-                           = "output_value_to_string"
+                           = "caml_output_value_to_string"
 
 let output_value oc v = output_string oc (marshal_to_string v [])
 
-external seek_out_blocking : out_channel -> int -> unit = "caml_seek_out"
+external seek_out_blocking : out_channel -> int -> unit = "caml_ml_seek_out"
 
 let seek_out oc pos = flush oc; seek_out_blocking oc pos
 
-external pos_out : out_channel -> int = "caml_pos_out"
-external out_channel_length : out_channel -> int = "caml_channel_size"
-external close_out_channel : out_channel -> unit = "caml_close_channel"
+external pos_out : out_channel -> int = "caml_ml_pos_out"
+external out_channel_length : out_channel -> int = "caml_ml_channel_size"
+external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
 
 let close_out oc = (try flush oc with _ -> ()); close_out_channel oc
 let close_out_noerr oc =
   (try flush oc with _ -> ());
   (try close_out_channel oc with _ -> ())
 external set_binary_mode_out : out_channel -> bool -> unit
-                             = "caml_set_binary_mode"
+                             = "caml_ml_set_binary_mode"
 
 (* General input functions *)
 
@@ -366,8 +364,8 @@ let open_in name =
 let open_in_bin name =
   open_in_gen [Open_rdonly; Open_binary] 0 name
 
-external input_char_blocking : in_channel -> char = "caml_input_char"
-external input_byte_blocking : in_channel -> int = "caml_input_char"
+external input_char_blocking : in_channel -> char = "caml_ml_input_char"
+external input_byte_blocking : in_channel -> int = "caml_ml_input_char"
 
 let rec input_char ic =
   try
@@ -376,7 +374,7 @@ let rec input_char ic =
     wait_inchan ic; input_char ic
 
 external unsafe_input_blocking : in_channel -> string -> int -> int -> int
-                               = "caml_input"
+                               = "caml_ml_input"
 
 let rec unsafe_input ic s ofs len =
   try
@@ -438,8 +436,8 @@ let input_binary_int ic =
   let b4 = input_byte ic in
   (n1 lsl 24) + (b2 lsl 16) + (b3 lsl 8) + b4
 
-external unmarshal : string -> int -> 'a = "input_value_from_string"
-external marshal_data_size : string -> int -> int = "marshal_data_size"
+external unmarshal : string -> int -> 'a = "caml_input_value_from_string"
+external marshal_data_size : string -> int -> int = "caml_marshal_data_size"
 
 let input_value ic =
   let header = string_create 20 in
@@ -450,13 +448,13 @@ let input_value ic =
   really_input ic buffer 20 bsize;
   unmarshal buffer 0
 
-external seek_in : in_channel -> int -> unit = "caml_seek_in"
-external pos_in : in_channel -> int = "caml_pos_in"
-external in_channel_length : in_channel -> int = "caml_channel_size"
-external close_in : in_channel -> unit = "caml_close_channel"
+external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
+external pos_in : in_channel -> int = "caml_ml_pos_in"
+external in_channel_length : in_channel -> int = "caml_ml_channel_size"
+external close_in : in_channel -> unit = "caml_ml_close_channel"
 let close_in_noerr ic = (try close_in ic with _ -> ());;
 external set_binary_mode_in : in_channel -> bool -> unit
-                            = "caml_set_binary_mode"
+                            = "caml_ml_set_binary_mode"
 
 (* Output functions on standard output *)
 
@@ -488,28 +486,37 @@ let read_float () = float_of_string(read_line())
 
 module LargeFile =
   struct
-    external seek_out : out_channel -> int64 -> unit = "caml_seek_out_64"
-    external pos_out : out_channel -> int64 = "caml_pos_out_64"
-    external out_channel_length : out_channel -> int64 = "caml_channel_size_64"
-    external seek_in : in_channel -> int64 -> unit = "caml_seek_in_64"
-    external pos_in : in_channel -> int64 = "caml_pos_in_64"
-    external in_channel_length : in_channel -> int64 = "caml_channel_size_64"
+    external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64"
+    external pos_out : out_channel -> int64 = "caml_ml_pos_out_64"
+    external out_channel_length : out_channel -> int64
+                                = "caml_ml_channel_size_64"
+    external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64"
+    external pos_in : in_channel -> int64 = "caml_ml_pos_in_64"
+    external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64"
   end
 
 (* Formats *)
 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
 external format_of_string :
  ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity"
-external string_of_format : ('a, 'b, 'c, 'd) format4 -> string = "%identity"
-
+external string_of_format_sys :
+ ('a, 'b, 'c, 'd) format4 -> string = "%identity"
 external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity"
+
 let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 ->
               ('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 ->
-  string_to_format (string_of_format fmt1 ^ string_of_format fmt2);;
+  string_to_format (string_of_format_sys fmt1 ^ string_of_format_sys fmt2);;
+
+let string_of_format f =
+  let s = string_of_format_sys f in
+  let l = string_length s in
+  let r = string_create l in
+  string_blit s 0 r 0 l;
+  r
 
 (* Miscellaneous *)
 
-external sys_exit : int -> 'a = "sys_exit"
+external sys_exit : int -> 'a = "caml_sys_exit"
 
 let exit_function = ref flush_all
 
@@ -523,6 +530,7 @@ let exit retcode =
   do_at_exit ();
   sys_exit retcode
 
-external register_named_value: string -> 'a -> unit = "register_named_value"
+external register_named_value : string -> 'a -> unit
+                              = "caml_register_named_value"
 
 let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c
index 400de65c..ac230406 100644
--- a/otherlibs/threads/scheduler.c
+++ b/otherlibs/threads/scheduler.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: scheduler.c,v 1.57 2003/10/10 13:13:21 doligez Exp $ */
+/* $Id: scheduler.c,v 1.58 2003/12/29 22:15:02 doligez Exp $ */
 
 /* The thread scheduler */
 
@@ -514,7 +514,7 @@ try_again:
 static void check_callback(void)
 {
   if (callback_depth > 1)
-    fatal_error("Thread: deadlock during callback");
+    caml_fatal_error("Thread: deadlock during callback");
 }
 
 /* Reschedule without suspending the current thread */
diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli
index 1ea357c0..5bff4a08 100644
--- a/otherlibs/threads/thread.mli
+++ b/otherlibs/threads/thread.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: thread.mli,v 1.27 2001/12/28 23:14:14 guesdon Exp $ *)
+(* $Id: thread.mli,v 1.27.6.1 2004/06/30 09:32:40 doligez Exp $ *)
 
 (** Lightweight threads. *)
 
@@ -70,7 +70,7 @@ val wait_write : Unix.file_descr -> unit
    on the given Unix file descriptor. *)
 
 val wait_timed_read : Unix.file_descr -> float -> bool
-(** See {!Thread.wait_timed_read}.*)
+(** See {!Thread.wait_timed_write}.*)
 
 val wait_timed_write : Unix.file_descr -> float -> bool
 (** Same as {!Thread.wait_read} and {!Thread.wait_write}, but wait for at most
diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml
index 14a54e9d..5f2dd412 100644
--- a/otherlibs/threads/threadUnix.ml
+++ b/otherlibs/threads/threadUnix.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: threadUnix.ml,v 1.18 2001/12/07 13:40:23 xleroy Exp $ *)
+(* $Id: threadUnix.ml,v 1.18.6.1 2004/06/22 17:18:49 remy Exp $ *)
 
 (* Module [ThreadUnix]: thread-compatible system calls *)
 
@@ -23,6 +23,7 @@ let waitpid = Unix.waitpid
 let system = Unix.system
 let read = Unix.read
 let write = Unix.write
+let single_write = Unix.single_write
 let select = Unix.select
 let pipe = Unix.pipe
 let open_process_in = Unix.open_process_in
diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli
index d4aa3f76..2ab67cd7 100644
--- a/otherlibs/threads/threadUnix.mli
+++ b/otherlibs/threads/threadUnix.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: threadUnix.mli,v 1.21 2001/12/28 23:14:14 guesdon Exp $ *)
+(* $Id: threadUnix.mli,v 1.21.6.1 2004/06/22 17:18:49 remy Exp $ *)
 
 (** Thread-compatible system calls.
 
@@ -34,6 +34,7 @@ val system : string -> Unix.process_status
 
 val read : Unix.file_descr -> string -> int -> int -> int
 val write : Unix.file_descr -> string -> int -> int -> int
+val single_write : Unix.file_descr -> string -> int -> int -> int
 
 (** {6 Input/output with timeout} *)
 
diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml
index a7158314..a17a1a4f 100644
--- a/otherlibs/threads/unix.ml
+++ b/otherlibs/threads/unix.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unix.ml,v 1.13 2003/03/20 16:24:03 xleroy Exp $ *)
+(* $Id: unix.ml,v 1.16.2.1 2004/06/22 17:18:49 remy Exp $ *)
 
 (* An alternate implementation of the Unix module from ../unix
    which is safe in conjunction with bytecode threads. *)
@@ -154,7 +154,7 @@ let handle_unix_error f arg =
     exit 2
 
 external environment : unit -> string array = "unix_environment"
-external getenv: string -> string = "sys_getenv"
+external getenv: string -> string = "caml_sys_getenv"
 external putenv: string -> string -> unit = "unix_putenv"
 
 type interval_timer =
@@ -201,7 +201,10 @@ external openfile : string -> open_flag list -> file_perm -> file_descr
 
 external close : file_descr -> unit = "unix_close"
 external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read"
-external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write"
+external unsafe_write : file_descr -> string -> int -> int -> int
+    = "unix_write"
+external unsafe_single_write : file_descr -> string -> int -> int -> int 
+    = "unix_single_write"
 
 let rec read fd buf ofs len =
   try
@@ -219,13 +222,22 @@ let rec write fd buf ofs len =
   with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
     wait_write fd; write fd buf ofs len
 
+let rec single_write fd buf ofs len =
+  try
+    if ofs < 0 || len < 0 || ofs > String.length buf - len
+    then invalid_arg "Unix.partial_write"
+    else unsafe_single_write fd buf ofs len
+  with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
+    wait_write fd; single_write fd buf ofs len
+
 external in_channel_of_descr : file_descr -> in_channel
-                             = "caml_open_descriptor_in"
+                             = "caml_ml_open_descriptor_in"
 external out_channel_of_descr : file_descr -> out_channel
-                              = "caml_open_descriptor_out"
-external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor"
+                              = "caml_ml_open_descriptor_out"
+external descr_of_in_channel : in_channel -> file_descr
+                             = "caml_channel_descriptor"
 external descr_of_out_channel : out_channel -> file_descr
-                              = "channel_descriptor"
+                              = "caml_channel_descriptor"
 
 type seek_command =
     SEEK_SET
@@ -268,7 +280,8 @@ external link : string -> string -> unit = "unix_link"
 
 module LargeFile =
   struct
-    external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64"
+    external lseek : file_descr -> int64 -> seek_command -> int64
+                   = "unix_lseek_64"
     external truncate : string -> int64 -> unit = "unix_truncate_64"
     external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64"
     type stats =
@@ -353,7 +366,8 @@ external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf"
 external _execv : string -> string array -> 'a = "unix_execv"
 external _execve : string -> string array -> string array -> 'a = "unix_execve"
 external _execvp : string -> string array -> 'a = "unix_execvp"
-external _execvpe : string -> string array -> string array -> 'a = "unix_execvpe"
+external _execvpe : string -> string array -> string array -> 'a
+                  = "unix_execvpe"
 
 (* Disable the timer interrupt before doing exec, because some OS
    keep sending timer interrupts to the exec'ed code.
@@ -393,7 +407,8 @@ let execvpe proc args =
   do_exec (fun () -> _execvpe proc args)
 
 external fork : unit -> int = "unix_fork"
-external _waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid"
+external _waitpid : wait_flag list -> int -> int * process_status
+                  = "unix_waitpid"
 
 let wait_pid pid = 
   match wait_pid_aux pid with
@@ -480,7 +495,7 @@ external getgrnam : string -> group_entry = "unix_getgrnam"
 external getpwuid : int -> passwd_entry = "unix_getpwuid"
 external getgrgid : int -> group_entry = "unix_getgrgid"
 
-type inet_addr
+type inet_addr = string
 
 external inet_addr_of_string : string -> inet_addr
                                     = "unix_inet_addr_of_string"
@@ -488,10 +503,18 @@ external string_of_inet_addr : inet_addr -> string
                                     = "unix_string_of_inet_addr"
 
 let inet_addr_any = inet_addr_of_string "0.0.0.0"
+let inet_addr_loopback = inet_addr_of_string "127.0.0.1"
+let inet6_addr_any =
+  try inet_addr_of_string "::" with Failure _ -> inet_addr_any
+let inet6_addr_loopback =
+  try inet_addr_of_string "::1" with Failure _ -> inet_addr_loopback
+
+let is_inet6_addr s = String.length s = 16
 
 type socket_domain =
     PF_UNIX
   | PF_INET
+  | PF_INET6
 
 type socket_type =
     SOCK_STREAM
@@ -503,6 +526,10 @@ type sockaddr =
     ADDR_UNIX of string
   | ADDR_INET of inet_addr * int
 
+let domain_of_sockaddr = function
+    ADDR_UNIX _ -> PF_UNIX
+  | ADDR_INET(a, _) -> if is_inet6_addr a then PF_INET6 else PF_INET
+
 type shutdown_command =
     SHUTDOWN_RECEIVE
   | SHUTDOWN_SEND
@@ -577,7 +604,8 @@ external setsockopt_int : file_descr -> socket_int_option -> int -> unit
                                           = "unix_setsockopt_int"
 external getsockopt_optint : file_descr -> socket_optint_option -> int option
                                           = "unix_getsockopt_optint"
-external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit
+external setsockopt_optint
+         : file_descr -> socket_optint_option -> int option -> unit
                                           = "unix_setsockopt_optint"
 external getsockopt_float : file_descr -> socket_float_option -> float
                                           = "unix_getsockopt_float"
@@ -670,6 +698,135 @@ external getservbyname : string -> string -> service_entry
                                          = "unix_getservbyname"
 external getservbyport : int -> string -> service_entry
                                          = "unix_getservbyport"
+type addr_info =
+  { ai_family : socket_domain;
+    ai_socktype : socket_type;
+    ai_protocol : int;
+    ai_addr : sockaddr;
+    ai_canonname : string }
+
+type getaddrinfo_option =
+    AI_FAMILY of socket_domain
+  | AI_SOCKTYPE of socket_type
+  | AI_PROTOCOL of int
+  | AI_NUMERICHOST
+  | AI_CANONNAME
+  | AI_PASSIVE
+
+external getaddrinfo_system
+  : string -> string -> getaddrinfo_option list -> addr_info list
+  = "unix_getaddrinfo"
+
+let getaddrinfo_emulation node service opts =
+  (* Parse options *)
+  let opt_socktype = ref None
+  and opt_protocol = ref 0
+  and opt_passive = ref false in
+  List.iter
+    (function AI_SOCKTYPE s -> opt_socktype := Some s
+            | AI_PROTOCOL p -> opt_protocol := p
+            | AI_PASSIVE -> opt_passive := true
+            | _ -> ())
+    opts;
+  (* Determine socket types and port numbers *)
+  let get_port ty kind =
+    if service = "" then [ty, 0] else
+      try
+        [ty, int_of_string service]
+      with Failure _ ->
+      try
+        [ty, (getservbyname service kind).s_port]
+      with Not_found -> [] 
+  in
+  let ports =
+    match !opt_socktype with
+    | None ->
+        get_port SOCK_STREAM "tcp" @ get_port SOCK_DGRAM "udp"
+    | Some SOCK_STREAM ->
+        get_port SOCK_STREAM "tcp"
+    | Some SOCK_DGRAM ->
+        get_port SOCK_DGRAM "udp"
+    | Some ty ->
+        if service = "" then [ty, 0] else [] in
+  (* Determine IP addresses *)
+  let addresses =
+    if node = "" then
+      if List.mem AI_PASSIVE opts
+      then [inet_addr_any, "0.0.0.0"]
+      else [inet_addr_loopback, "127.0.0.1"]
+    else
+      try
+        [inet_addr_of_string node, node]
+      with Failure _ ->
+      try
+        let he = gethostbyname node in
+        List.map
+          (fun a -> (a, he.h_name))
+          (Array.to_list he.h_addr_list)
+      with Not_found ->
+        [] in
+  (* Cross-product of addresses and ports *)
+  List.flatten
+    (List.map 
+      (fun (ty, port) ->
+        List.map
+          (fun (addr, name) ->
+            { ai_family = PF_INET;
+              ai_socktype = ty;
+              ai_protocol = !opt_protocol;
+              ai_addr = ADDR_INET(addr, port);
+              ai_canonname = name })
+          addresses)
+      ports)
+
+let getaddrinfo node service opts =
+  try
+    List.rev(getaddrinfo_system node service opts)
+  with Invalid_argument _ ->
+    getaddrinfo_emulation node service opts
+
+type name_info =
+  { ni_hostname : string;
+    ni_service : string }
+
+type getnameinfo_option =
+    NI_NOFQDN
+  | NI_NUMERICHOST
+  | NI_NAMEREQD
+  | NI_NUMERICSERV
+  | NI_DGRAM
+
+external getnameinfo_system
+  : sockaddr -> getnameinfo_option list -> name_info
+  = "unix_getnameinfo"
+
+let getnameinfo_emulation addr opts =
+  match addr with
+  | ADDR_UNIX f ->
+      { ni_hostname = ""; ni_service = f } (* why not? *)
+  | ADDR_INET(a, p) ->
+      let hostname =
+        try
+          if List.mem NI_NUMERICHOST opts then raise Not_found;
+          (gethostbyaddr a).h_name
+        with Not_found ->
+          if List.mem NI_NAMEREQD opts then raise Not_found;
+          string_of_inet_addr a in
+      let service =
+        try
+          if List.mem NI_NUMERICSERV opts then raise Not_found;
+          let kind = if List.mem NI_DGRAM opts then "udp" else "tcp" in
+          (getservbyport p kind).s_name
+        with Not_found ->
+          string_of_int p in
+      { ni_hostname = hostname; ni_service = service }
+
+let getnameinfo addr opts =
+  try
+    getnameinfo_system addr opts
+  with Invalid_argument _ ->
+    getnameinfo_emulation addr opts
+
 type terminal_io = {
     mutable c_ignbrk: bool;
     mutable c_brkint: bool;
@@ -716,7 +873,7 @@ external tcgetattr: file_descr -> terminal_io = "unix_tcgetattr"
 type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH
 
 external tcsetattr: file_descr -> setattr_when -> terminal_io -> unit
-               = "unix_tcsetattr"
+                  = "unix_tcsetattr"
 external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak"
 external tcdrain: file_descr -> unit = "unix_tcdrain"
 
@@ -889,10 +1046,8 @@ let close_process_full (inchan, outchan, errchan) =
 (* High-level network functions *)
 
 let open_connection sockaddr =
-  let domain =
-    match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
   let sock =
-    socket domain SOCK_STREAM 0 in
+    socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
   try
     connect sock sockaddr;
     (in_channel_of_descr sock, out_channel_of_descr sock)
@@ -903,10 +1058,8 @@ let shutdown_connection inchan =
   shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
 
 let establish_server server_fun sockaddr =
-  let domain =
-    match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
   let sock =
-    socket domain SOCK_STREAM 0 in
+    socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
   setsockopt sock SO_REUSEADDR true;
   bind sock sockaddr;
   listen sock 5;
diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend
index cb4704c7..045cd7f7 100644
--- a/otherlibs/unix/.depend
+++ b/otherlibs/unix/.depend
@@ -1,281 +1,357 @@
-accept.o: accept.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
+accept.o: accept.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \
   socketaddr.h
-access.o: access.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h unixsupport.h
-addrofstr.o: addrofstr.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/fail.h unixsupport.h socketaddr.h
-alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-bind.o: bind.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h \
-  socketaddr.h
-chdir.o: chdir.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-chmod.o: chmod.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-chown.o: chown.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-chroot.o: chroot.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-close.o: close.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-closedir.o: closedir.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-connect.o: connect.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/signals.h unixsupport.h socketaddr.h
+access.o: access.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
+addrofstr.o: addrofstr.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h \
+  unixsupport.h socketaddr.h
+alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+bind.o: bind.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h socketaddr.h
+chdir.o: chdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+chmod.o: chmod.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+chown.o: chown.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+chroot.o: chroot.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+close.o: close.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+closedir.o: closedir.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+connect.o: connect.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/signals.h \
+  unixsupport.h socketaddr.h
 cst2constr.o: cst2constr.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h cst2constr.h
+cstringv.o: cstringv.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h unixsupport.h
+dup.o: dup.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/fail.h cst2constr.h
-cstringv.o: cstringv.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-dup.o: dup.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-dup2.o: dup2.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-envir.o: envir.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h
-errmsg.o: errmsg.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h
-execv.o: execv.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
+  ../../byterun/misc.h unixsupport.h
+dup2.o: dup2.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+envir.o: envir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h
+errmsg.o: errmsg.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h
+execv.o: execv.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h unixsupport.h
+execve.o: execve.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h unixsupport.h
+execvp.o: execvp.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h unixsupport.h
+exit.o: exit.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+fchmod.o: fchmod.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+fchown.o: fchown.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+fcntl.o: fcntl.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+fork.o: fork.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+ftruncate.o: ftruncate.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/io.h unixsupport.h
+getaddrinfo.o: getaddrinfo.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-execve.o: execve.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
+  ../../byterun/signals.h unixsupport.h cst2constr.h socketaddr.h
+getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
+getegid.o: getegid.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+geteuid.o: geteuid.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+getgid.o: getgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+getgr.o: getgr.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/fail.h ../../byterun/alloc.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-execvp.o: execvp.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
+getgroups.o: getgroups.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+gethost.o: gethost.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-exit.o: exit.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-fchmod.o: fchmod.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-fchown.o: fchown.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-fcntl.o: fcntl.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-fork.o: fork.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-ftruncate.o: ftruncate.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/io.h unixsupport.h
-getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h unixsupport.h
-getegid.o: getegid.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-geteuid.o: geteuid.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-getgid.o: getgid.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-getgr.o: getgr.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/fail.h ../../byterun/alloc.h ../../byterun/memory.h \
-  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h
-getgroups.o: getgroups.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h unixsupport.h
-gethost.o: gethost.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h ../../byterun/fail.h ../../byterun/signals.h \
-  unixsupport.h socketaddr.h
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
+  ../../byterun/signals.h unixsupport.h socketaddr.h
 gethostname.o: gethostname.c ../../byterun/mlvalues.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
-getlogin.o: getlogin.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h unixsupport.h
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+getlogin.o: getlogin.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+getnameinfo.o: getnameinfo.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
+  ../../byterun/signals.h unixsupport.h socketaddr.h
 getpeername.o: getpeername.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h
+getpid.o: getpid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h unixsupport.h socketaddr.h
-getpid.o: getpid.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-getppid.o: getppid.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-getproto.o: getproto.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h
-getpw.o: getpw.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h
-getserv.o: getserv.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/misc.h unixsupport.h
+getppid.o: getppid.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+getproto.o: getproto.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
+  unixsupport.h
+getpw.o: getpw.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h
+getserv.o: getserv.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
+  unixsupport.h
 getsockname.o: getsockname.c ../../byterun/mlvalues.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h unixsupport.h socketaddr.h
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h
 gettimeofday.o: gettimeofday.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+getuid.o: getuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
-getuid.o: getuid.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-gmtime.o: gmtime.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/misc.h unixsupport.h
+gmtime.o: gmtime.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h unixsupport.h
-itimer.o: itimer.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
+itimer.o: itimer.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h unixsupport.h
+kill.o: kill.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/fail.h unixsupport.h \
+  ../../byterun/signals.h
+link.o: link.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+listen.o: listen.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+lockf.o: lockf.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/signals.h unixsupport.h
+lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/io.h \
+  unixsupport.h
+mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+mkfifo.o: mkfifo.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+nice.o: nice.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+open.o: open.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
+opendir.o: opendir.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+pipe.o: pipe.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
+putenv.o: putenv.c ../../byterun/memory.h ../../byterun/compatibility.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 unixsupport.h
-kill.o: kill.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/fail.h unixsupport.h ../../byterun/signals.h
-link.o: link.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-listen.o: listen.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-lockf.o: lockf.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/io.h unixsupport.h
-mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-mkfifo.o: mkfifo.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-nice.o: nice.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-open.o: open.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
+read.o: read.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
-opendir.o: opendir.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-pipe.o: pipe.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
+readdir.o: readdir.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h \
   ../../byterun/alloc.h unixsupport.h
-putenv.o: putenv.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 unixsupport.h
-read.o: read.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
+readlink.o: readlink.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+rename.o: rename.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+rewinddir.o: rewinddir.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+select.o: select.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
+sendrecv.o: sendrecv.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h \
-  ../../byterun/signals.h unixsupport.h
-readdir.o: readdir.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/fail.h ../../byterun/alloc.h unixsupport.h
-readlink.o: readlink.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h unixsupport.h
-rename.o: rename.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-rewinddir.o: rewinddir.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-select.o: select.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/signals.h unixsupport.h socketaddr.h
+setgid.o: setgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+setsid.o: setsid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+setuid.o: setuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+shutdown.o: shutdown.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+signals.o: signals.c ../../byterun/alloc.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/mlvalues.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
-sendrecv.o: sendrecv.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \
+sleep.o: sleep.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/signals.h unixsupport.h
+socket.o: socket.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+socketaddr.o: socketaddr.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h \
   socketaddr.h
-setgid.o: setgid.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-setsid.o: setsid.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-setuid.o: setuid.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-shutdown.o: shutdown.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-signals.o: signals.c ../../byterun/alloc.h ../../byterun/misc.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \
+socketpair.o: socketpair.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+sockopt.o: sockopt.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h socketaddr.h
+stat.o: stat.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
-sleep.o: sleep.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/signals.h unixsupport.h
-socket.o: socket.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-socketaddr.o: socketaddr.c ../../byterun/mlvalues.h \
+  ../../byterun/minor_gc.h ../../byterun/alloc.h unixsupport.h \
+  cst2constr.h ../../byterun/io.h
+strofaddr.o: strofaddr.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h socketaddr.h
+symlink.o: symlink.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+termios.o: termios.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+time.o: time.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
+times.o: times.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
   ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h socketaddr.h
-socketpair.o: socketpair.c ../../byterun/mlvalues.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
-sockopt.o: sockopt.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h unixsupport.h socketaddr.h
-stat.o: stat.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \
-  unixsupport.h cst2constr.h ../../byterun/io.h
-strofaddr.o: strofaddr.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h unixsupport.h socketaddr.h
-symlink.o: symlink.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-termios.o: termios.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h unixsupport.h
-time.o: time.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h unixsupport.h
-times.o: times.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h unixsupport.h
-truncate.o: truncate.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/io.h unixsupport.h
-umask.o: umask.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
+truncate.o: truncate.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/io.h unixsupport.h
+umask.o: umask.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
 unixsupport.o: unixsupport.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/callback.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h \
+  cst2constr.h
+unlink.o: unlink.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/callback.h \
-  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
-  unixsupport.h cst2constr.h
-unlink.o: unlink.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-utimes.o: utimes.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h
-wait.o: wait.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/misc.h unixsupport.h
+utimes.o: utimes.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+wait.o: wait.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
+write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
-write.o: write.c ../../byterun/mlvalues.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/misc.h \
-  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h \
-  ../../byterun/signals.h unixsupport.h
 unixLabels.cmi: unix.cmi 
 unix.cmo: unix.cmi 
 unix.cmx: unix.cmi 
diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
index 60a2c787..554a3abd 100644
--- a/otherlibs/unix/Makefile
+++ b/otherlibs/unix/Makefile
@@ -11,7 +11,7 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile,v 1.37 2002/06/27 11:36:02 xleroy Exp $
+# $Id: Makefile,v 1.38 2004/04/09 13:25:20 xleroy Exp $
 
 # Makefile for the Unix interface library
 
@@ -28,9 +28,10 @@ COMPFLAGS=-warn-error A
 OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \
   chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o \
   dup.o dup2.o envir.o errmsg.o execv.o execve.o execvp.o exit.o \
-  fchmod.o fchown.o fcntl.o fork.o ftruncate.o getcwd.o getegid.o \
-  geteuid.o getgid.o getgr.o getgroups.o gethost.o gethostname.o \
-  getlogin.o getpeername.o getpid.o getppid.o getproto.o getpw.o \
+  fchmod.o fchown.o fcntl.o fork.o ftruncate.o \
+  getaddrinfo.o getcwd.o getegid.o geteuid.o getgid.o \
+  getgr.o getgroups.o gethost.o gethostname.o getlogin.o \
+  getnameinfo.o getpeername.o getpid.o getppid.o getproto.o getpw.o \
   gettimeofday.o getserv.o getsockname.o getuid.o \
   gmtime.o itimer.o kill.o link.o listen.o lockf.o lseek.o mkdir.o \
   mkfifo.o nice.o open.o opendir.o pipe.o putenv.o read.o \
diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c
index 36e2ad25..ab2985f7 100644
--- a/otherlibs/unix/addrofstr.c
+++ b/otherlibs/unix/addrofstr.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: addrofstr.c,v 1.10 2001/12/07 13:40:24 xleroy Exp $ */
+/* $Id: addrofstr.c,v 1.11 2004/04/09 13:25:20 xleroy Exp $ */
 
 #include <mlvalues.h>
 #include <fail.h>
@@ -23,16 +23,25 @@
 
 CAMLprim value unix_inet_addr_of_string(value s)
 {
-#ifdef HAS_INET_ATON
+#if defined(HAS_IPV6)
+  struct in_addr address;
+  struct in6_addr address6;
+  if (inet_pton(AF_INET, String_val(s), &address) > 0)
+    return alloc_inet_addr(&address);
+  else if (inet_pton(AF_INET6, String_val(s), &address6) > 0)
+    return alloc_inet6_addr(&address6);
+  else
+    failwith("inet_addr_of_string");
+#elif defined(HAS_INET_ATON)
   struct in_addr address;
   if (inet_aton(String_val(s), &address) == 0)
     failwith("inet_addr_of_string");
-  return alloc_inet_addr(address.s_addr);
+  return alloc_inet_addr(&address);
 #else
-  unsigned int address;
-  address = inet_addr(String_val(s));
-  if (address == (unsigned int) -1) failwith("inet_addr_of_string");
-  return alloc_inet_addr(address);
+  struct in_addr address;
+  address.s_addr = inet_addr(String_val(s));
+  if (address.s_addr == (uint32) -1) failwith("inet_addr_of_string");
+  return alloc_inet_addr(&address);
 #endif
 }
 
diff --git a/otherlibs/unix/closedir.c b/otherlibs/unix/closedir.c
index 78c6c1dc..1cb60553 100644
--- a/otherlibs/unix/closedir.c
+++ b/otherlibs/unix/closedir.c
@@ -11,10 +11,11 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: closedir.c,v 1.8 2001/12/07 13:40:26 xleroy Exp $ */
+/* $Id: closedir.c,v 1.9 2004/02/14 10:21:22 xleroy Exp $ */
 
 #include <mlvalues.h>
 #include "unixsupport.h"
+#include <errno.h>
 #include <sys/types.h>
 #ifdef HAS_DIRENT
 #include <dirent.h>
@@ -22,8 +23,11 @@
 #include <sys/dir.h>
 #endif
 
-CAMLprim value unix_closedir(value d)
+CAMLprim value unix_closedir(value vd)
 {
-  closedir((DIR *) d);
+  DIR * d = DIR_Val(vd);
+  if (d == (DIR *) NULL) unix_error(EBADF, "closedir", Nothing);
+  closedir(d);
+  DIR_Val(vd) = (DIR *) NULL;
   return Val_unit;
 }
diff --git a/otherlibs/unix/cst2constr.h b/otherlibs/unix/cst2constr.h
index 552f3300..c6785e16 100644
--- a/otherlibs/unix/cst2constr.h
+++ b/otherlibs/unix/cst2constr.h
@@ -11,10 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cst2constr.h,v 1.6 2001/12/07 13:40:26 xleroy Exp $ */
+/* $Id: cst2constr.h,v 1.7 2004/04/09 13:25:21 xleroy Exp $ */
 
-#ifdef __STDC__
-value cst_to_constr(int, int *, int, int);
-#else
-value cst_to_constr();
-#endif
+extern value cst_to_constr(int n, int * tbl, int size, int deflt);
diff --git a/otherlibs/unix/errmsg.c b/otherlibs/unix/errmsg.c
index d18a4473..a642779e 100644
--- a/otherlibs/unix/errmsg.c
+++ b/otherlibs/unix/errmsg.c
@@ -11,39 +11,18 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: errmsg.c,v 1.11 2001/12/07 13:40:27 xleroy Exp $ */
+/* $Id: errmsg.c,v 1.12 2004/05/23 15:53:50 xleroy Exp $ */
 
 #include <errno.h>
+#include <string.h>
 #include <mlvalues.h>
 #include <alloc.h>
 
 extern int error_table[];
 
-#ifdef HAS_STRERROR
-
-extern char * strerror(int);
-
 CAMLprim value unix_error_message(value err)
 {
   int errnum;
   errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
   return copy_string(strerror(errnum));
 }
-
-#else
-
-extern int sys_nerr;
-extern char *sys_errlist[];
-
-CAMLprim value unix_error_message(value err)
-{
-  int errnum;
-  errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
-  if (errnum < 0 || errnum >= sys_nerr) {
-    return copy_string("Unknown error");
-  } else {
-    return copy_string(sys_errlist[errnum]);
-  }
-}
-
-#endif
diff --git a/otherlibs/unix/getaddrinfo.c b/otherlibs/unix/getaddrinfo.c
new file mode 100644
index 00000000..a4db8e92
--- /dev/null
+++ b/otherlibs/unix/getaddrinfo.c
@@ -0,0 +1,133 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2004 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All 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: getaddrinfo.c,v 1.1 2004/04/09 13:25:21 xleroy Exp $ */
+
+#include <string.h>
+#include <mlvalues.h>
+#include <alloc.h>
+#include <memory.h>
+#include <fail.h>
+#include <signals.h>
+#include "unixsupport.h"
+#include "cst2constr.h"
+
+#if defined(HAS_SOCKETS) && defined(HAS_IPV6)
+
+#include "socketaddr.h"
+#ifndef _WIN32
+#include <sys/types.h>
+#include <netdb.h>
+#endif
+
+extern int socket_domain_table[]; /* from socket.c */
+extern int socket_type_table[];   /* from socket.c */
+
+static value convert_addrinfo(struct addrinfo * a)
+{
+  CAMLparam0();
+  CAMLlocal3(vres,vaddr,vcanonname);
+  union sock_addr_union sa;
+
+  memcpy(&sa.s_gen, a->ai_addr, sizeof(struct sockaddr));
+  vaddr = alloc_sockaddr(&sa, sizeof(struct sockaddr));
+  vcanonname = copy_string(a->ai_canonname == NULL ? "" : a->ai_canonname);
+  vres = alloc_small(5, 0);
+  Field(vres, 0) = cst_to_constr(a->ai_family, socket_domain_table, 3, 0);
+  Field(vres, 1) = cst_to_constr(a->ai_socktype, socket_type_table, 4, 0);
+  Field(vres, 2) = Val_int(a->ai_protocol);
+  Field(vres, 3) = vaddr;
+  Field(vres, 4) = vcanonname;
+  CAMLreturn(vres);
+}
+
+CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
+{
+  CAMLparam3(vnode, vserv, vopts);
+  CAMLlocal3(vres, v, e);
+  mlsize_t len;
+  char * node, * serv;
+  struct addrinfo hints;
+  struct addrinfo * res, * r;
+  int retcode;
+
+  /* Extract "node" parameter */
+  len = string_length(vnode);
+  if (len == 0) {
+    node = NULL;
+  } else {
+    node = stat_alloc(len + 1);
+    strcpy(node, String_val(vnode));
+  }
+  /* Extract "service" parameter */
+  len = string_length(vserv);
+  if (len == 0) {
+    serv = NULL;
+  } else {
+    serv = stat_alloc(len + 1);
+    strcpy(serv, String_val(vserv));
+  }
+  /* Parse options, set hints */
+  memset(&hints, 0, sizeof(hints));
+  hints.ai_family = PF_UNSPEC;
+  for (/*nothing*/; Is_block(vopts); vopts = Field(vopts, 1)) {
+    v = Field(vopts, 0);
+    if (Is_block(v))
+      switch (Tag_val(v)) {
+      case 0:                   /* AI_FAMILY of socket_domain */
+        hints.ai_family = socket_domain_table[Int_val(Field(v, 0))];
+        break;
+      case 1:                   /* AI_SOCKTYPE of socket_type */
+        hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))];
+        break;
+      case 2:                   /* AI_PROTOCOL of int */
+        hints.ai_protocol = Int_val(Field(v, 0));
+        break;
+      }
+    else
+      switch (Int_val(v)) {
+      case 0:                   /* AI_NUMERICHOST */
+        hints.ai_flags |= AI_NUMERICHOST; break;
+      case 1:                   /* AI_CANONNAME */
+        hints.ai_flags |= AI_CANONNAME; break;
+      case 2:                   /* AI_PASSIVE */
+        hints.ai_flags |= AI_PASSIVE; break;
+      }
+  }
+  /* Do the call */
+  enter_blocking_section();
+  retcode = getaddrinfo(node, serv, &hints, &res);
+  leave_blocking_section();
+  if (node != NULL) stat_free(node);
+  if (serv != NULL) stat_free(serv);
+  /* Convert result */
+  vres = Val_int(0);
+  if (retcode == 0) {
+    for (r = res; r != NULL; r = r->ai_next) {
+      e = convert_addrinfo(r);
+      v = alloc_small(2, 0);
+      Field(v, 0) = e;
+      Field(v, 1) = vres;
+      vres = v;
+    }
+    freeaddrinfo(res);
+  }
+  CAMLreturn(vres);
+}
+
+#else
+
+CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
+{ invalid_argument("getaddrinfo not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c
index 33a9a31a..22f24a78 100644
--- a/otherlibs/unix/gethost.c
+++ b/otherlibs/unix/gethost.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: gethost.c,v 1.23 2002/06/07 09:49:40 xleroy Exp $ */
+/* $Id: gethost.c,v 1.24 2004/04/09 13:25:21 xleroy Exp $ */
 
 #include <string.h>
 #include <mlvalues.h>
@@ -43,8 +43,15 @@ extern int socket_domain_table[];
 static value alloc_one_addr(char const *a)
 {
   struct in_addr addr;
-  memmove (&addr, a, entry_h_length);
-  return alloc_inet_addr(addr.s_addr);
+#ifdef HAS_IPV6
+  struct in6_addr addr6;
+  if (entry_h_length == 16) {
+    memmove(&addr6, a, 16);
+    return alloc_inet6_addr(&addr6);
+  }
+#endif
+  memmove (&addr, a, 4);
+  return alloc_inet_addr(&addr);
 }
 
 static value alloc_host_entry(struct hostent *entry)
@@ -75,7 +82,7 @@ static value alloc_host_entry(struct hostent *entry)
 
 CAMLprim value unix_gethostbyaddr(value a)
 {
-  uint32 adr = GET_INET_ADDR(a);
+  struct in_addr adr = GET_INET_ADDR(a);
   struct hostent * hp;
 #if HAS_GETHOSTBYADDR_R == 7
   struct hostent h;
diff --git a/otherlibs/unix/getnameinfo.c b/otherlibs/unix/getnameinfo.c
new file mode 100644
index 00000000..a4f653f2
--- /dev/null
+++ b/otherlibs/unix/getnameinfo.c
@@ -0,0 +1,67 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2004 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All 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: getnameinfo.c,v 1.1 2004/04/09 13:25:21 xleroy Exp $ */
+
+#include <string.h>
+#include <mlvalues.h>
+#include <alloc.h>
+#include <memory.h>
+#include <fail.h>
+#include <signals.h>
+#include "unixsupport.h"
+
+#if defined(HAS_SOCKETS) && defined(HAS_IPV6)
+
+#include "socketaddr.h"
+#ifndef _WIN32
+#include <sys/types.h>
+#include <netdb.h>
+#endif
+
+static int getnameinfo_flag_table[] = {
+  NI_NOFQDN, NI_NUMERICHOST, NI_NAMEREQD, NI_NUMERICSERV, NI_DGRAM
+};
+
+CAMLprim value unix_getnameinfo(value vaddr, value vopts)
+{
+  CAMLparam0();
+  CAMLlocal3(vhost, vserv, vres);
+  union sock_addr_union addr;
+  socklen_param_type addr_len;
+  char host[4096];
+  char serv[1024];
+  int opts, retcode;
+
+  get_sockaddr(vaddr, &addr, &addr_len);
+  opts = convert_flag_list(vopts, getnameinfo_flag_table);
+  enter_blocking_section();
+  retcode = 
+    getnameinfo((const struct sockaddr *) &addr.s_gen, addr_len,
+                host, sizeof(host), serv, sizeof(serv), opts);
+  leave_blocking_section();
+  if (retcode != 0) raise_not_found(); /* TODO: detailed error reporting? */
+  vhost = copy_string(host);
+  vserv = copy_string(serv);
+  vres = alloc_small(2, 0);
+  Field(vres, 0) = vhost;
+  Field(vres, 1) = vserv;
+  CAMLreturn(vres);
+}
+
+#else
+
+CAMLprim value unix_getnameinfo(value vaddr, value vopts)
+{ invalid_argument("getnameinfo not implemented"); }
+
+#endif
diff --git a/otherlibs/unix/getpeername.c b/otherlibs/unix/getpeername.c
index 8f594dd8..0ce98b0a 100644
--- a/otherlibs/unix/getpeername.c
+++ b/otherlibs/unix/getpeername.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getpeername.c,v 1.9 2001/12/07 13:40:29 xleroy Exp $ */
+/* $Id: getpeername.c,v 1.10 2004/04/09 13:25:21 xleroy Exp $ */
 
 #include <mlvalues.h>
 #include "unixsupport.h"
@@ -26,7 +26,7 @@ CAMLprim value unix_getpeername(value sock)
   union sock_addr_union addr;
   socklen_param_type addr_len;
 
-  addr_len = sizeof(sock_addr);
+  addr_len = sizeof(addr);
   retcode = getpeername(Int_val(sock), &addr.s_gen, &addr_len);
   if (retcode == -1) uerror("getpeername", Nothing);
   return alloc_sockaddr(&addr, addr_len);
diff --git a/otherlibs/unix/itimer.c b/otherlibs/unix/itimer.c
index fc05b956..c8c07978 100644
--- a/otherlibs/unix/itimer.c
+++ b/otherlibs/unix/itimer.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: itimer.c,v 1.12 2001/12/07 13:40:31 xleroy Exp $ */
+/* $Id: itimer.c,v 1.13 2003/11/21 16:00:52 xleroy Exp $ */
 
 #include <mlvalues.h>
 #include <alloc.h>
@@ -20,20 +20,28 @@
 
 #ifdef HAS_SETITIMER
 
+#include <math.h>
 #include <sys/time.h>
 
-#define Get_timeval(tv) \
-  (double) tv.tv_sec + (double) tv.tv_usec / 1e6
-#define Set_timeval(tv, d) \
-  tv.tv_sec = (int)(d), \
-  tv.tv_usec = (int) (1e6 * ((d) - tv.tv_sec))
+static void unix_set_timeval(struct timeval * tv, double d)
+{
+  double integr, frac;
+  frac = modf(d, &integr);
+  /* Round time up so that if d is small but not 0, we end up with
+     a non-0 timeval. */
+  tv->tv_sec = integr;
+  tv->tv_usec = ceil(1e6 * frac);
+  if (tv->tv_usec >= 1000000) { tv->tv_sec++; tv->tv_usec = 0; }
+}
 
 static value unix_convert_itimer(struct itimerval *tp)
 {
+#define Get_timeval(tv) (double) tv.tv_sec + (double) tv.tv_usec / 1e6
   value res = alloc_small(Double_wosize * 2, Double_array_tag);
   Store_double_field(res, 0, Get_timeval(tp->it_interval));
   Store_double_field(res, 1, Get_timeval(tp->it_value));
   return res;
+#undef Get_timeval
 }
 
 static int itimers[3] = { ITIMER_REAL, ITIMER_VIRTUAL, ITIMER_PROF };
@@ -41,8 +49,8 @@ static int itimers[3] = { ITIMER_REAL, ITIMER_VIRTUAL, ITIMER_PROF };
 CAMLprim value unix_setitimer(value which, value newval)
 {
   struct itimerval new, old;
-  Set_timeval(new.it_interval, Double_field(newval, 0));
-  Set_timeval(new.it_value, Double_field(newval, 1));
+  unix_set_timeval(&new.it_interval, Double_field(newval, 0));
+  unix_set_timeval(&new.it_value, Double_field(newval, 1));
   if (setitimer(itimers[Int_val(which)], &new, &old) == -1)
     uerror("setitimer", Nothing);
   return unix_convert_itimer(&old);
diff --git a/otherlibs/unix/lockf.c b/otherlibs/unix/lockf.c
index 43c5f554..771de995 100644
--- a/otherlibs/unix/lockf.c
+++ b/otherlibs/unix/lockf.c
@@ -11,11 +11,12 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: lockf.c,v 1.11 2001/12/07 13:40:31 xleroy Exp $ */
+/* $Id: lockf.c,v 1.13 2004/06/11 23:16:14 doligez Exp $ */
 
 #include <errno.h>
 #include <fcntl.h>
 #include <mlvalues.h>
+#include <signals.h>
 #include "unixsupport.h"
 
 #if defined(F_GETLK) && defined(F_SETLK) && defined(F_SETLKW)
@@ -44,7 +45,9 @@ CAMLprim value unix_lockf(value fd, value cmd, value span)
     break;
   case 1: /* F_LOCK */
     l.l_type = F_WRLCK;
+    enter_blocking_section();
     ret = fcntl(fildes, F_SETLKW, &l);
+    leave_blocking_section();
     break;
   case 2: /* F_TLOCK */
     l.l_type = F_WRLCK;
@@ -64,7 +67,9 @@ CAMLprim value unix_lockf(value fd, value cmd, value span)
     break;
   case 4: /* F_RLOCK */
     l.l_type = F_RDLCK;
+    enter_blocking_section();
     ret = fcntl(fildes, F_SETLKW, &l);
+    leave_blocking_section();
     break;
   case 5: /* F_TRLOCK */
     l.l_type = F_RDLCK;
diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c
index 77440d98..467316a3 100644
--- a/otherlibs/unix/opendir.c
+++ b/otherlibs/unix/opendir.c
@@ -11,9 +11,10 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: opendir.c,v 1.8 2001/12/07 13:40:32 xleroy Exp $ */
+/* $Id: opendir.c,v 1.9 2004/02/14 10:21:22 xleroy Exp $ */
 
 #include <mlvalues.h>
+#include <alloc.h>
 #include "unixsupport.h"
 #include <sys/types.h>
 #ifdef HAS_DIRENT
@@ -25,7 +26,10 @@
 CAMLprim value unix_opendir(value path)
 {
   DIR * d;
+  value res;
   d = opendir(String_val(path));
   if (d == (DIR *) NULL) uerror("opendir", path);
-  return (value) d;
+  res = alloc_small(1, Abstract_tag);
+  DIR_Val(res) = d;
+  return res;
 }
diff --git a/otherlibs/unix/readdir.c b/otherlibs/unix/readdir.c
index 09fb7724..786a21f0 100644
--- a/otherlibs/unix/readdir.c
+++ b/otherlibs/unix/readdir.c
@@ -11,12 +11,13 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: readdir.c,v 1.11 2003/03/03 17:12:33 xleroy Exp $ */
+/* $Id: readdir.c,v 1.12 2004/02/14 10:21:23 xleroy Exp $ */
 
 #include <mlvalues.h>
 #include <fail.h>
 #include <alloc.h>
 #include "unixsupport.h"
+#include <errno.h>
 #include <sys/types.h>
 #ifdef HAS_DIRENT
 #include <dirent.h>
@@ -26,10 +27,12 @@ typedef struct dirent directory_entry;
 typedef struct direct directory_entry;
 #endif
 
-CAMLprim value unix_readdir(value d)
+CAMLprim value unix_readdir(value vd)
 {
+  DIR * d;
   directory_entry * e;
-
+  d = DIR_Val(vd);
+  if (d == (DIR *) NULL) unix_error(EBADF, "readdir", Nothing);
   e = readdir((DIR *) d);
   if (e == (directory_entry *) NULL) raise_end_of_file();
   return copy_string(e->d_name);
diff --git a/otherlibs/unix/rewinddir.c b/otherlibs/unix/rewinddir.c
index 88fe19cd..588ee30e 100644
--- a/otherlibs/unix/rewinddir.c
+++ b/otherlibs/unix/rewinddir.c
@@ -11,10 +11,11 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: rewinddir.c,v 1.10 2001/12/07 13:40:33 xleroy Exp $ */
+/* $Id: rewinddir.c,v 1.11 2004/06/19 15:38:31 xleroy Exp $ */
 
 #include <mlvalues.h>
 #include "unixsupport.h"
+#include <errno.h>
 #include <sys/types.h>
 #ifdef HAS_DIRENT
 #include <dirent.h>
@@ -24,9 +25,11 @@
 
 #ifdef HAS_REWINDDIR
 
-CAMLprim value unix_rewinddir(value d)
+CAMLprim value unix_rewinddir(value vd)
 {
-  rewinddir((DIR *) d);
+  DIR * d = DIR_Val(vd);
+  if (d == (DIR *) NULL) unix_error(EBADF, "rewinddir", Nothing);
+  rewinddir(d);
   return Val_unit;
 }
 
diff --git a/otherlibs/unix/socket.c b/otherlibs/unix/socket.c
index 894b177f..9b4bbdb4 100644
--- a/otherlibs/unix/socket.c
+++ b/otherlibs/unix/socket.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: socket.c,v 1.9 2001/12/07 13:40:35 xleroy Exp $ */
+/* $Id: socket.c,v 1.10 2004/04/09 13:25:21 xleroy Exp $ */
 
 #include <mlvalues.h>
 #include "unixsupport.h"
@@ -22,7 +22,14 @@
 #include <sys/socket.h>
 
 int socket_domain_table[] = {
-  PF_UNIX, PF_INET
+  PF_UNIX, PF_INET,
+#if defined(HAS_IPV6)
+  PF_INET6
+#elif defined(PF_UNDEF)
+  PF_UNDEF
+#else
+  0
+#endif
 };
 
 int socket_type_table[] = {
diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c
index 39faf72f..6691a69e 100644
--- a/otherlibs/unix/socketaddr.c
+++ b/otherlibs/unix/socketaddr.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: socketaddr.c,v 1.21 2001/12/07 13:40:35 xleroy Exp $ */
+/* $Id: socketaddr.c,v 1.22 2004/04/09 13:25:22 xleroy Exp $ */
 
 #include <string.h>
 #include <mlvalues.h>
@@ -28,17 +28,29 @@
 #define EAFNOSUPPORT WSAEAFNOSUPPORT
 #endif
 
-value alloc_inet_addr(uint32 a)
+CAMLprim value alloc_inet_addr(struct in_addr * a)
 {
   value res;
   /* Use a string rather than an abstract block so that it can be
      marshaled safely.  Remember that a is in network byte order,
-     hence can be marshaled safely. */
-  res = alloc_string(sizeof(uint32));
-  GET_INET_ADDR(res) = a;
+     hence is marshaled in an endian-independent manner. */
+  res = alloc_string(4);
+  memcpy(String_val(res), a, 4);
   return res;
 }
 
+#ifdef HAS_IPV6
+
+CAMLprim value alloc_inet6_addr(struct in6_addr * a)
+{
+  value res;
+  res = alloc_string(16);
+  memcpy(String_val(res), a, 16);
+  return res;
+}
+
+#endif
+
 void get_sockaddr(value mladr,
                   union sock_addr_union * adr /*out*/,
                   socklen_param_type * adr_len /*out*/)
@@ -62,18 +74,22 @@ void get_sockaddr(value mladr,
     }
 #endif
   case 1:                       /* ADDR_INET */
-    {
-      char * p;
-      int n;
-      for (p = (char *) &adr->s_inet, n = sizeof(adr->s_inet);
-           n > 0; p++, n--)
-        *p = 0;
-      adr->s_inet.sin_family = AF_INET;
-      adr->s_inet.sin_addr.s_addr = GET_INET_ADDR(Field(mladr, 0));
-      adr->s_inet.sin_port = htons(Int_val(Field(mladr, 1)));
-      *adr_len = sizeof(struct sockaddr_in);
+#ifdef HAS_IPV6
+    if (string_length(Field(mladr, 0)) == 16) {
+      memset(&adr->s_inet6, 0, sizeof(struct sockaddr_in6));
+      adr->s_inet6.sin6_family = AF_INET6;
+      adr->s_inet6.sin6_addr = GET_INET6_ADDR(Field(mladr, 0));
+      adr->s_inet6.sin6_port = htons(Int_val(Field(mladr, 1)));
+      *adr_len = sizeof(struct sockaddr_in6);
       break;
     }
+#endif
+    memset(&adr->s_inet, 0, sizeof(struct sockaddr_in));
+    adr->s_inet.sin_family = AF_INET;
+    adr->s_inet.sin_addr = GET_INET_ADDR(Field(mladr, 0));
+    adr->s_inet.sin_port = htons(Int_val(Field(mladr, 1)));
+    *adr_len = sizeof(struct sockaddr_in);
+    break;
   }
 }
 
@@ -93,7 +109,7 @@ value alloc_sockaddr(union sock_addr_union * adr /*in*/,
     }
 #endif
   case AF_INET:
-    { value a = alloc_inet_addr(adr->s_inet.sin_addr.s_addr);
+    { value a = alloc_inet_addr(&adr->s_inet.sin_addr);
       Begin_root (a);
         res = alloc_small(2, 1);
         Field(res,0) = a;
@@ -101,6 +117,17 @@ value alloc_sockaddr(union sock_addr_union * adr /*in*/,
       End_roots();
       break;
     }
+#ifdef HAS_IPV6
+  case AF_INET6:
+    { value a = alloc_inet6_addr(&adr->s_inet6.sin6_addr);
+      Begin_root (a);
+        res = alloc_small(2, 1);
+        Field(res,0) = a;
+        Field(res,1) = Val_int(ntohs(adr->s_inet6.sin6_port));
+      End_roots();
+      break;
+    }
+#endif
   default:
     unix_error(EAFNOSUPPORT, "", Nothing);
   }
diff --git a/otherlibs/unix/socketaddr.h b/otherlibs/unix/socketaddr.h
index cc7adb09..507f7bb0 100644
--- a/otherlibs/unix/socketaddr.h
+++ b/otherlibs/unix/socketaddr.h
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: socketaddr.h,v 1.14 2001/12/07 13:40:35 xleroy Exp $ */
+/* $Id: socketaddr.h,v 1.15 2004/04/09 13:25:22 xleroy Exp $ */
 
 #include <misc.h>
 #include <sys/types.h>
@@ -24,21 +24,26 @@ union sock_addr_union {
   struct sockaddr s_gen;
   struct sockaddr_un s_unix;
   struct sockaddr_in s_inet;
+#ifdef HAS_IPV6
+  struct sockaddr_in6 s_inet6;
+#endif
 };
 
-extern union sock_addr_union sock_addr;
-
 #ifdef HAS_SOCKLEN_T
 typedef socklen_t socklen_param_type;
 #else
 typedef int socklen_param_type;
 #endif
 
-void get_sockaddr (value mladdr,
-                   union sock_addr_union * addr /*out*/,
-                   socklen_param_type * addr_len /*out*/);
+extern void get_sockaddr (value mladdr,
+                          union sock_addr_union * addr /*out*/,
+                          socklen_param_type * addr_len /*out*/);
 CAMLprim value alloc_sockaddr (union sock_addr_union * addr /*in*/,
                       socklen_param_type addr_len);
-CAMLprim value alloc_inet_addr (uint32 inaddr);
+CAMLprim value alloc_inet_addr (struct in_addr * inaddr);
+#define GET_INET_ADDR(v) (*((struct in_addr *) (v)))
 
-#define GET_INET_ADDR(v) (*((uint32 *) (v)))
+#ifdef HAS_IPV6
+CAMLprim value alloc_inet6_addr (struct in6_addr * inaddr);
+#define GET_INET6_ADDR(v) (*((struct in6_addr *) (v)))
+#endif
diff --git a/otherlibs/unix/strofaddr.c b/otherlibs/unix/strofaddr.c
index 2469f1a2..ece84b58 100644
--- a/otherlibs/unix/strofaddr.c
+++ b/otherlibs/unix/strofaddr.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: strofaddr.c,v 1.8 2001/12/07 13:40:36 xleroy Exp $ */
+/* $Id: strofaddr.c,v 1.9 2004/04/09 13:25:22 xleroy Exp $ */
 
 #include <mlvalues.h>
 #include <alloc.h>
@@ -23,9 +23,22 @@
 
 CAMLprim value unix_string_of_inet_addr(value a)
 {
-  struct in_addr address;
-  address.s_addr = GET_INET_ADDR(a);
-  return copy_string(inet_ntoa(address));
+  char * res;
+#ifdef HAS_IPV6
+  char buffer[64];
+  if (string_length(a) == 16)
+    res = (char *)
+      inet_ntop(AF_INET6, (const void *) &GET_INET6_ADDR(a),
+                buffer, sizeof(buffer));
+  else
+    res = (char *)
+      inet_ntop(AF_INET, (const void *) &GET_INET_ADDR(a),
+                buffer, sizeof(buffer));
+#else
+  res = inet_ntoa(GET_INET_ADDR(a));
+#endif
+  if (res == NULL) uerror("string_of_inet_addr", Nothing);
+  return copy_string(res);
 }
 
 #else
diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index 82880c75..6643be45 100644
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unix.ml,v 1.56 2002/07/12 09:47:54 xleroy Exp $ *)
+(* $Id: unix.ml,v 1.60.2.2 2004/07/02 09:37:17 doligez Exp $ *)
 
 type error =
     E2BIG
@@ -109,7 +109,7 @@ let handle_unix_error f arg =
     exit 2
 
 external environment : unit -> string array = "unix_environment"
-external getenv: string -> string = "sys_getenv"
+external getenv: string -> string = "caml_sys_getenv"
 external putenv: string -> string -> unit = "unix_putenv"
 
 type process_status =
@@ -161,6 +161,7 @@ external openfile : string -> open_flag list -> file_perm -> file_descr
 external close : file_descr -> unit = "unix_close"
 external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read"
 external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write"
+external unsafe_single_write : file_descr -> string -> int -> int -> int = "unix_single_write"
 
 let read fd buf ofs len =
   if ofs < 0 || len < 0 || ofs > String.length buf - len
@@ -170,14 +171,22 @@ let write fd buf ofs len =
   if ofs < 0 || len < 0 || ofs > String.length buf - len
   then invalid_arg "Unix.write"
   else unsafe_write fd buf ofs len
+(* write misbehaves because it attempts to write all data by making repeated
+   calls to the Unix write function (see comment in write.c and unix.mli).
+   partial_write fixes this by never calling write twice. *)
+let single_write fd buf ofs len =
+  if ofs < 0 || len < 0 || ofs > String.length buf - len
+  then invalid_arg "Unix.single_write"
+  else unsafe_single_write fd buf ofs len
 
 external in_channel_of_descr : file_descr -> in_channel
-                             = "caml_open_descriptor_in"
+                             = "caml_ml_open_descriptor_in"
 external out_channel_of_descr : file_descr -> out_channel
-                              = "caml_open_descriptor_out"
-external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor"
+                              = "caml_ml_open_descriptor_out"
+external descr_of_in_channel : in_channel -> file_descr
+                             = "caml_channel_descriptor"
 external descr_of_out_channel : out_channel -> file_descr
-                              = "channel_descriptor"
+                              = "caml_channel_descriptor"
 
 type seek_command =
     SEEK_SET
@@ -262,6 +271,11 @@ external clear_nonblock : file_descr -> unit = "unix_clear_nonblock"
 external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec"
 external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec"
 
+(* FD_CLOEXEC should be supported on all Unix systems these days,
+   but just in case... *)
+let try_set_close_on_exec fd =
+  try set_close_on_exec fd; true with Invalid_argument _ -> false
+
 external mkdir : string -> file_perm -> unit = "unix_mkdir"
 external rmdir : string -> unit = "unix_rmdir"
 external chdir : string -> unit = "unix_chdir"
@@ -373,7 +387,9 @@ external getgrnam : string -> group_entry = "unix_getgrnam"
 external getpwuid : int -> passwd_entry = "unix_getpwuid"
 external getgrgid : int -> group_entry = "unix_getgrgid"
 
-type inet_addr
+type inet_addr = string
+
+let is_inet6_addr s = String.length s = 16
 
 external inet_addr_of_string : string -> inet_addr
                                     = "unix_inet_addr_of_string"
@@ -381,10 +397,16 @@ external string_of_inet_addr : inet_addr -> string
                                     = "unix_string_of_inet_addr"
 
 let inet_addr_any = inet_addr_of_string "0.0.0.0"
+let inet_addr_loopback = inet_addr_of_string "127.0.0.1"
+let inet6_addr_any =
+  try inet_addr_of_string "::" with Failure _ -> inet_addr_any
+let inet6_addr_loopback =
+  try inet_addr_of_string "::1" with Failure _ -> inet_addr_loopback
 
 type socket_domain =
     PF_UNIX
   | PF_INET
+  | PF_INET6
 
 type socket_type =
     SOCK_STREAM
@@ -396,6 +418,10 @@ type sockaddr =
     ADDR_UNIX of string
   | ADDR_INET of inet_addr * int
 
+let domain_of_sockaddr = function
+    ADDR_UNIX _ -> PF_UNIX
+  | ADDR_INET(a, _) -> if is_inet6_addr a then PF_INET6 else PF_INET
+
 type shutdown_command =
     SHUTDOWN_RECEIVE
   | SHUTDOWN_SEND
@@ -517,6 +543,136 @@ external getservbyname : string -> string -> service_entry
                                          = "unix_getservbyname"
 external getservbyport : int -> string -> service_entry
                                          = "unix_getservbyport"
+
+type addr_info =
+  { ai_family : socket_domain;
+    ai_socktype : socket_type;
+    ai_protocol : int;
+    ai_addr : sockaddr;
+    ai_canonname : string }
+
+type getaddrinfo_option =
+    AI_FAMILY of socket_domain
+  | AI_SOCKTYPE of socket_type
+  | AI_PROTOCOL of int
+  | AI_NUMERICHOST
+  | AI_CANONNAME
+  | AI_PASSIVE
+
+external getaddrinfo_system
+  : string -> string -> getaddrinfo_option list -> addr_info list
+  = "unix_getaddrinfo"
+
+let getaddrinfo_emulation node service opts =
+  (* Parse options *)
+  let opt_socktype = ref None
+  and opt_protocol = ref 0
+  and opt_passive = ref false in
+  List.iter
+    (function AI_SOCKTYPE s -> opt_socktype := Some s
+            | AI_PROTOCOL p -> opt_protocol := p
+            | AI_PASSIVE -> opt_passive := true
+            | _ -> ())
+    opts;
+  (* Determine socket types and port numbers *)
+  let get_port ty kind =
+    if service = "" then [ty, 0] else
+      try
+        [ty, int_of_string service]
+      with Failure _ ->
+      try
+        [ty, (getservbyname service kind).s_port]
+      with Not_found -> [] 
+  in
+  let ports =
+    match !opt_socktype with
+    | None ->
+        get_port SOCK_STREAM "tcp" @ get_port SOCK_DGRAM "udp"
+    | Some SOCK_STREAM ->
+        get_port SOCK_STREAM "tcp"
+    | Some SOCK_DGRAM ->
+        get_port SOCK_DGRAM "udp"
+    | Some ty ->
+        if service = "" then [ty, 0] else [] in
+  (* Determine IP addresses *)
+  let addresses =
+    if node = "" then
+      if List.mem AI_PASSIVE opts
+      then [inet_addr_any, "0.0.0.0"]
+      else [inet_addr_loopback, "127.0.0.1"]
+    else
+      try
+        [inet_addr_of_string node, node]
+      with Failure _ ->
+      try
+        let he = gethostbyname node in
+        List.map
+          (fun a -> (a, he.h_name))
+          (Array.to_list he.h_addr_list)
+      with Not_found ->
+        [] in
+  (* Cross-product of addresses and ports *)
+  List.flatten
+    (List.map 
+      (fun (ty, port) ->
+        List.map
+          (fun (addr, name) ->
+            { ai_family = PF_INET;
+              ai_socktype = ty;
+              ai_protocol = !opt_protocol;
+              ai_addr = ADDR_INET(addr, port);
+              ai_canonname = name })
+          addresses)
+      ports)
+
+let getaddrinfo node service opts =
+  try
+    List.rev(getaddrinfo_system node service opts)
+  with Invalid_argument _ ->
+    getaddrinfo_emulation node service opts
+
+type name_info =
+  { ni_hostname : string;
+    ni_service : string }
+
+type getnameinfo_option =
+    NI_NOFQDN
+  | NI_NUMERICHOST
+  | NI_NAMEREQD
+  | NI_NUMERICSERV
+  | NI_DGRAM
+
+external getnameinfo_system
+  : sockaddr -> getnameinfo_option list -> name_info
+  = "unix_getnameinfo"
+
+let getnameinfo_emulation addr opts =
+  match addr with
+  | ADDR_UNIX f ->
+      { ni_hostname = ""; ni_service = f } (* why not? *)
+  | ADDR_INET(a, p) ->
+      let hostname =
+        try
+          if List.mem NI_NUMERICHOST opts then raise Not_found;
+          (gethostbyaddr a).h_name
+        with Not_found ->
+          if List.mem NI_NAMEREQD opts then raise Not_found;
+          string_of_inet_addr a in
+      let service =
+        try
+          if List.mem NI_NUMERICSERV opts then raise Not_found;
+          let kind = if List.mem NI_DGRAM opts then "udp" else "tcp" in
+          (getservbyport p kind).s_name
+        with Not_found ->
+          string_of_int p in
+      { ni_hostname = hostname; ni_service = service }
+
+let getnameinfo addr opts =
+  try
+    getnameinfo_system addr opts
+  with Invalid_argument _ ->
+    getnameinfo_emulation addr opts
+
 type terminal_io = {
     mutable c_ignbrk: bool;
     mutable c_brkint: bool;
@@ -643,10 +799,11 @@ type popen_process =
 let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
 
 let open_proc cmd proc input output toclose =
+  let cloexec = List.for_all try_set_close_on_exec toclose in
   match fork() with
      0 -> if input <> stdin then begin dup2 input stdin; close input end;
           if output <> stdout then begin dup2 output stdout; close output end;
-          List.iter close toclose;
+          if not cloexec then List.iter close toclose;
           execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |];
           exit 127
   | id -> Hashtbl.add popen_processes proc id
@@ -677,11 +834,12 @@ let open_process cmd =
   (inchan, outchan)
 
 let open_proc_full cmd env proc input output error toclose =
+  let cloexec = List.for_all try_set_close_on_exec toclose in
   match fork() with
      0 -> dup2 input stdin; close input;
           dup2 output stdout; close output;
           dup2 error stderr; close error;
-          List.iter close toclose;
+          if not cloexec then List.iter close toclose;
           execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env;
           exit 127
   | id -> Hashtbl.add popen_processes proc id
@@ -736,12 +894,11 @@ let close_process_full (inchan, outchan, errchan) =
 (* High-level network functions *)
 
 let open_connection sockaddr =
-  let domain =
-    match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
   let sock =
-    socket domain SOCK_STREAM 0 in
+    socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
   try
     connect sock sockaddr;
+    ignore(try_set_close_on_exec sock);
     (in_channel_of_descr sock, out_channel_of_descr sock)
   with exn ->
     close sock; raise exn
@@ -750,10 +907,8 @@ let shutdown_connection inchan =
   shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
 
 let establish_server server_fun sockaddr =
-  let domain =
-    match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
   let sock =
-    socket domain SOCK_STREAM 0 in
+    socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
   setsockopt sock SO_REUSEADDR true;
   bind sock sockaddr;
   listen sock 5;
@@ -763,6 +918,7 @@ let establish_server server_fun sockaddr =
        leave a zombie process *)
     match fork() with
        0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *)
+            ignore(try_set_close_on_exec s);
             let inchan = in_channel_of_descr s in
             let outchan = out_channel_of_descr s in
             server_fun inchan outchan;
diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index 36d24796..1ecb4b9f 100644
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unix.mli,v 1.71 2003/09/14 16:46:31 doligez Exp $ *)
+(* $Id: unix.mli,v 1.79.2.3 2004/07/08 08:40:47 xleroy Exp $ *)
 
 (** Interface to the Unix system *)
 
@@ -153,19 +153,22 @@ type wait_flag =
   | WUNTRACED (** report also the children that receive stop signals. *)
 (** Flags for {!Unix.waitpid}. *)
 
-val execv : string -> string array -> unit
+val execv : string -> string array -> 'a
 (** [execv prog args] execute the program in file [prog], with
-   the arguments [args], and the current process environment. *)
+   the arguments [args], and the current process environment. 
+   These [execv*] functions never return: on success, the current 
+   program is replaced by the new one; 
+   on failure, a {!Unix.Unix_error} exception is raised. *)
 
-val execve : string -> string array -> string array -> unit
+val execve : string -> string array -> string array -> 'a
 (** Same as {!Unix.execv}, except that the third argument provides the
    environment to the program executed. *)
 
-val execvp : string -> string array -> unit
+val execvp : string -> string array -> 'a
 (** Same as {!Unix.execv} respectively, except that
    the program is searched in the path. *)
 
-val execvpe : string -> string array -> string array -> unit
+val execvpe : string -> string array -> string array -> 'a
 (** Same as {!Unix.execvp} respectively, except that
    the program is searched in the path. *)
 
@@ -178,7 +181,7 @@ val wait : unit -> int * process_status
    and termination status. *)
 
 val waitpid : wait_flag list -> int -> int * process_status
-(** Same as {!Unix.wait}, but waits for the process whose pid is given.
+(** Same as {!Unix.wait}, but waits for the child process whose pid is given.
    A pid of [-1] means wait for any child.
    A pid of [0] means wait for any child in the same process group
    as the current process.
@@ -218,7 +221,7 @@ val stdout : file_descr
 (** File descriptor for standard output.*)
 
 val stderr : file_descr
-(** File descriptor for standard standard error. *)
+(** File descriptor for standard error. *)
 
 type open_flag =
     O_RDONLY                    (** Open for reading *)
@@ -237,7 +240,8 @@ type open_flag =
 
 
 type file_perm = int
-(** The type of file access rights. *)
+(** The type of file access rights, e.g. [0o640] is read and write for user, 
+    read for group, none for others *)
 
 val openfile : string -> open_flag list -> file_perm -> file_descr
 (** Open the named file with the given flags. Third argument is
@@ -256,9 +260,13 @@ val write : file_descr -> string -> int -> int -> int
 (** [write fd buff ofs len] writes [len] characters to descriptor
    [fd], taking them from string [buff], starting at position [ofs]
    in string [buff]. Return the number of characters actually
-   written. *)
-
+   written.  [write] repeats the writing operation until all characters
+   have been written or an error occurs.  *)
 
+val single_write : file_descr -> string -> int -> int -> int
+(** Same as [write], but attempts to write only once.
+   Thus, if an error occurs, [single_write] guarantees that no data
+   has been written. *)
 
 (** {6 Interfacing with the standard input/output library} *)
 
@@ -628,11 +636,25 @@ val lockf : file_descr -> lock_command -> int -> unit
    [fd] (as set by {!Unix.lseek}), and extends [size] bytes forward if
    [size] is positive, [size] bytes backwards if [size] is negative,
    or to the end of the file if [size] is zero.
-   A write lock (set with [F_LOCK] or [F_TLOCK]) prevents any other
+   A write lock prevents any other
    process from acquiring a read or write lock on the region.
-   A read lock (set with [F_RLOCK] or [F_TRLOCK]) prevents any other
+   A read lock prevents any other
    process from acquiring a write lock on the region, but lets
-   other processes acquire read locks on it. *)
+   other processes acquire read locks on it.
+
+   The [F_LOCK] and [F_TLOCK] commands attempts to put a write lock
+   on the specified region.
+   The [F_RLOCK] and [F_TRLOCK] commands attempts to put a read lock
+   on the specified region.
+   If one or several locks put by another process prevent the current process
+   from acquiring the lock, [F_LOCK] and [F_RLOCK] block until these locks
+   are removed, while [F_TLOCK] and [F_TRLOCK] fail immediately with an
+   exception.
+   The [F_ULOCK] removes whatever locks the current process has on
+   the specified region.
+   Finally, the [F_TEST] command tests whether a write lock can be
+   acquired on the specified region, without actually putting a lock.
+   It returns immediately if successful, or fails otherwise. *)
 
 
 (** {6 Signals}
@@ -663,7 +685,7 @@ val sigpending : unit -> int list
 (** Return the set of blocked signals that are currently pending. *)
 
 val sigsuspend : int list -> unit
-(** [sigsuspend sigs] atomically sets the blocked signals to [sig]
+(** [sigsuspend sigs] atomically sets the blocked signals to [sigs]
    and waits for a non-ignored, non-blocked signal to be delivered.
    On return, the blocked signals are reset to their initial value. *)
 
@@ -713,10 +735,13 @@ val localtime : float -> tm
 
 val mktime : tm -> float * tm
 (** Convert a date and time, specified by the [tm] argument, into
-   a time in seconds, as returned by {!Unix.time}. Also return a normalized
-   copy of the given [tm] record, with the [tm_wday], [tm_yday],
-   and [tm_isdst] fields recomputed from the other fields.
-   The [tm] argument is interpreted in the local time zone. *)
+   a time in seconds, as returned by {!Unix.time}.  The [tm_isdst],
+   [tm_wday] and [tm_yday] fields of [tm] are ignored.  Also return a
+   normalized copy of the given [tm] record, with the [tm_wday],
+   [tm_yday], and [tm_isdst] fields recomputed from the other fields,
+   and the other fields normalized (so that, e.g., 40 October is
+   changed into 9 November).  The [tm] argument is interpreted in the
+   local time zone. *)
 
 val alarm : int -> int
 (** Schedule a [SIGALRM] signal after the given number of seconds. *)
@@ -835,24 +860,40 @@ type inet_addr
 (** The abstract type of Internet addresses. *)
 
 val inet_addr_of_string : string -> inet_addr
-(** Conversions between string with the format [XXX.YYY.ZZZ.TTT]
-   and Internet addresses. [inet_addr_of_string] raises [Failure]
-   when given a string that does not match this format. *)
+(** Conversion from the printable representation of an Internet
+    address to its internal representation.  The argument string
+    consists of 4 numbers separated by periods ([XXX.YYY.ZZZ.TTT])
+    for IPv4 addresses, and up to 8 numbers separated by colons
+    for IPv6 addresses.  Raise [Failure] when given a string that
+    does not match these formats. *)
 
 val string_of_inet_addr : inet_addr -> string
-(** See {!Unix.inet_addr_of_string}. *)
+(** Return the printable representation of the given Internet address.
+    See {!Unix.inet_addr_of_string} for a description of the
+    printable representation. *)
 
 val inet_addr_any : inet_addr
-(** A special Internet address, for use only with [bind], representing
+(** A special IPv4 address, for use only with [bind], representing
+   all the Internet addresses that the host machine possesses. *)
+
+val inet_addr_loopback : inet_addr
+(** A special IPv4 address representing the host machine ([127.0.0.1]). *)
+
+val inet6_addr_any : inet_addr
+(** A special IPv6 address, for use only with [bind], representing
    all the Internet addresses that the host machine possesses. *)
 
+val inet6_addr_loopback : inet_addr
+(** A special IPv6 address representing the host machine ([::1]). *)
+
 
 (** {6 Sockets} *)
 
 
 type socket_domain =
     PF_UNIX                     (** Unix domain *)
-  | PF_INET                     (** Internet domain *)
+  | PF_INET                     (** Internet domain (IPv4) *)
+  | PF_INET6                    (** Internet domain (IPv6) *)
 (** The type of socket domains. *)
 
 type socket_type =
@@ -875,6 +916,9 @@ val socket : socket_domain -> socket_type -> int -> file_descr
    given kind. The third argument is the protocol type; 0 selects
    the default protocol for that kind of sockets. *)
 
+val domain_of_sockaddr: sockaddr -> socket_domain
+(** Return the socket domain adequate for the given socket address. *)
+
 val socketpair :
   socket_domain -> socket_type -> int -> file_descr * file_descr
 (** Create a pair of unnamed sockets, connected together. *)
@@ -1017,8 +1061,8 @@ external setsockopt_float :
 val open_connection : sockaddr -> in_channel * out_channel
 (** Connect to a server at the given address.
    Return a pair of buffered channels connected to the server.
-   Remember to call {!Pervasives.flush} on the output channel at the right times
-   to ensure correct synchronization. *)
+   Remember to call {!Pervasives.flush} on the output channel at the right
+   times to ensure correct synchronization. *)
 
 val shutdown_connection : in_channel -> unit
 (** ``Shut down'' a connection established with {!Unix.open_connection};
@@ -1086,6 +1130,65 @@ val getservbyport : int -> string -> service_entry
 (** Find an entry in [services] with the given service number,
    or raise [Not_found]. *)
 
+type addr_info =
+  { ai_family : socket_domain;          (** Socket domain *)
+    ai_socktype : socket_type;          (** Socket type *)
+    ai_protocol : int;                  (** Socket protocol number *)
+    ai_addr : sockaddr;                 (** Address *)
+    ai_canonname : string               (** Canonical host name  *)
+  }
+(** Address information returned by {!Unix.getaddrinfo}. *)
+
+type getaddrinfo_option =
+    AI_FAMILY of socket_domain          (** Impose the given socket domain *)
+  | AI_SOCKTYPE of socket_type          (** Impose the given socket type *)
+  | AI_PROTOCOL of int                  (** Impose the given protocol  *)
+  | AI_NUMERICHOST                      (** Do not call name resolver, 
+                                            expect numeric IP address *)
+  | AI_CANONNAME                        (** Fill the [ai_canonname] field
+                                            of the result *)
+  | AI_PASSIVE                          (** Set address to ``any'' address
+                                            for use with {!Unix.bind} *)
+(** Options to {!Unix.getaddrinfo}. *)
+
+val getaddrinfo: 
+  string -> string -> getaddrinfo_option list -> addr_info list
+(** [getaddrinfo host service opts] returns a list of {!Unix.addr_info}
+    records describing socket parameters and addresses suitable for
+    communicating with the given host and service.  The empty list is
+    returned if the host or service names are unknown, or the constraints
+    expressed in [opts] cannot be satisfied.
+
+    [host] is either a host name or the string representation of an IP
+    address.  [host] can be given as the empty string; in this case,
+    the ``any'' address or the ``loopback'' address are used,
+    depending whether [opts] contains [AI_PASSIVE].
+    [service] is either a service name or the string representation of
+    a port number.  [service] can be given as the empty string;
+    in this case, the port field of the returned addresses is set to 0.
+    [opts] is a possibly empty list of options that allows the caller
+    to force a particular socket domain (e.g. IPv6 only or IPv4 only)
+    or a particular socket type (e.g. TCP only or UDP only). *)
+
+type name_info =
+  { ni_hostname : string;               (** Name or IP address of host *)
+    ni_service : string }               (** Name of service or port number *)
+(** Host and service information returned by {!Unix.getnameinfo}. *)
+
+type getnameinfo_option =
+    NI_NOFQDN            (** Do not qualify local host names *)
+  | NI_NUMERICHOST       (** Always return host as IP address *)
+  | NI_NAMEREQD          (** Fail if host name cannot be determined *)
+  | NI_NUMERICSERV       (** Always return service as port number *)
+  | NI_DGRAM             (** Consider the service as UDP-based
+                             instead of the default TCP *)
+(** Options to {!Unix.getnameinfo}. *)
+
+val getnameinfo : sockaddr -> getnameinfo_option list -> name_info
+(** [getnameinfo addr opts] returns the host name and service name
+    corresponding to the socket address [addr].  [opts] is a possibly
+    empty list of options that governs how these names are obtained.
+    Raise [Not_found] if an error occurs. *)
 
 
 (** {6 Terminal interface} *)
diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli
index 9864b995..e6b4d432 100644
--- a/otherlibs/unix/unixLabels.mli
+++ b/otherlibs/unix/unixLabels.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unixLabels.mli,v 1.10 2002/05/27 16:06:31 verlyck Exp $ *)
+(* $Id: unixLabels.mli,v 1.12.2.2 2004/07/02 09:37:17 doligez Exp $ *)
 
 (** Interface to the Unix system.
    To use as replacement to default {!Unix} module,
@@ -156,19 +156,22 @@ type wait_flag =
 (** Flags for {!UnixLabels.waitpid}. *)
 
 
-val execv : prog:string -> args:string array -> unit
+val execv : prog:string -> args:string array -> 'a
 (** [execv prog args] execute the program in file [prog], with
-   the arguments [args], and the current process environment. *)
+   the arguments [args], and the current process environment. 
+   These [execv*] functions never return: on success, the current 
+   program is replaced by the new one; 
+   on failure, a {!UnixLabels.Unix_error} exception is raised. *)
 
-val execve : prog:string -> args:string array -> env:string array -> unit
+val execve : prog:string -> args:string array -> env:string array -> 'a
 (** Same as {!UnixLabels.execv}, except that the third argument provides the
    environment to the program executed. *)
 
-val execvp : prog:string -> args:string array -> unit
+val execvp : prog:string -> args:string array -> 'a
 (** Same as {!UnixLabels.execv} respectively, except that
    the program is searched in the path. *)
 
-val execvpe : prog:string -> args:string array -> env:string array -> unit
+val execvpe : prog:string -> args:string array -> env:string array -> 'a
 (** Same as {!UnixLabels.execvp} respectively, except that
    the program is searched in the path. *)
 
@@ -260,7 +263,15 @@ val write : file_descr -> buf:string -> pos:int -> len:int -> int
 (** [write fd buff ofs len] writes [len] characters to descriptor
    [fd], taking them from string [buff], starting at position [ofs]
    in string [buff]. Return the number of characters actually
-   written. *)
+   written.
+
+   When an error is reported some characters might have already been
+   written.  Use [single_write] instead to ensure that this is not the
+   case. *)
+
+val single_write : file_descr -> buf:string -> pos:int -> len:int -> int
+(** Same as [write] but ensures that all errors are reported and
+   that no character has ever been written when an error is reported. *)
 
 
 (** {6 Interfacing with the standard input/output library} *)
@@ -853,17 +864,32 @@ type inet_addr = Unix.inet_addr
 (** The abstract type of Internet addresses. *)
 
 val inet_addr_of_string : string -> inet_addr
-(** Conversions between string with the format [XXX.YYY.ZZZ.TTT]
-   and Internet addresses. [inet_addr_of_string] raises [Failure]
-   when given a string that does not match this format. *)
+(** Conversion from the printable representation of an Internet
+    address to its internal representation.  The argument string
+    consists of 4 numbers separated by periods ([XXX.YYY.ZZZ.TTT])
+    for IPv4 addresses, and up to 8 numbers separated by colons
+    for IPv6 addresses.  Raise [Failure] when given a string that
+    does not match these formats. *)
 
 val string_of_inet_addr : inet_addr -> string
-(** See {!UnixLabels.inet_addr_of_string}. *)
+(** Return the printable representation of the given Internet address.
+    See {!Unix.inet_addr_of_string} for a description of the
+    printable representation. *)
 
 val inet_addr_any : inet_addr
-(** A special Internet address, for use only with [bind], representing
+(** A special IPv4 address, for use only with [bind], representing
+   all the Internet addresses that the host machine possesses. *)
+
+val inet_addr_loopback : inet_addr
+(** A special IPv4 address representing the host machine ([127.0.0.1]). *)
+
+val inet6_addr_any : inet_addr
+(** A special IPv6 address, for use only with [bind], representing
    all the Internet addresses that the host machine possesses. *)
 
+val inet6_addr_loopback : inet_addr
+(** A special IPv6 address representing the host machine ([::1]). *)
+
 
 (** {6 Sockets} *)
 
@@ -872,6 +898,7 @@ type socket_domain =
   Unix.socket_domain =
       PF_UNIX                             (** Unix domain *)
     | PF_INET                             (** Internet domain *)
+    | PF_INET6                            (** Internet domain (IPv6) *)
 (** The type of socket domains. *)
 
 type socket_type =
@@ -893,6 +920,9 @@ type sockaddr =
    domain; [addr] is the Internet address of the machine, and
    [port] is the port number. *)
 
+val domain_of_sockaddr: sockaddr -> socket_domain
+(** Return the socket domain adequate for the given socket address. *)
+
 val socket :
   domain:socket_domain -> kind:socket_type -> protocol:int -> file_descr
 (** Create a new socket in the given domain, and with the
@@ -1122,7 +1152,65 @@ val getservbyport : int -> protocol:string -> service_entry
 (** Find an entry in [services] with the given service number,
    or raise [Not_found]. *)
 
-
+type addr_info =
+  { ai_family : socket_domain;          (** Socket domain *)
+    ai_socktype : socket_type;          (** Socket type *)
+    ai_protocol : int;                  (** Socket protocol number *)
+    ai_addr : sockaddr;                 (** Address *)
+    ai_canonname : string               (** Canonical host name  *)
+  }
+(** Address information returned by {!Unix.getaddrinfo}. *)
+
+type getaddrinfo_option =
+    AI_FAMILY of socket_domain          (** Impose the given socket domain *)
+  | AI_SOCKTYPE of socket_type          (** Impose the given socket type *)
+  | AI_PROTOCOL of int                  (** Impose the given protocol  *)
+  | AI_NUMERICHOST                      (** Do not call name resolver, 
+                                            expect numeric IP address *)
+  | AI_CANONNAME                        (** Fill the [ai_canonname] field
+                                            of the result *)
+  | AI_PASSIVE                          (** Set address to ``any'' address
+                                            for use with {!Unix.bind} *)
+(** Options to {!Unix.getaddrinfo}. *)
+
+val getaddrinfo: 
+  string -> string -> getaddrinfo_option list -> addr_info list
+(** [getaddrinfo host service opts] returns a list of {!Unix.addr_info}
+    records describing socket parameters and addresses suitable for
+    communicating with the given host and service.  The empty list is
+    returned if the host or service names are unknown, or the constraints
+    expressed in [opts] cannot be satisfied.
+
+    [host] is either a host name or the string representation of an IP
+    address.  [host] can be given as the empty string; in this case,
+    the ``any'' address or the ``loopback'' address are used,
+    depending whether [opts] contains [AI_PASSIVE].
+    [service] is either a service name or the string representation of
+    a port number.  [service] can be given as the empty string;
+    in this case, the port field of the returned addresses is set to 0.
+    [opts] is a possibly empty list of options that allows the caller
+    to force a particular socket domain (e.g. IPv6 only, or IPv4 only)
+    or a particular socket type (e.g. TCP only or UDP only). *)
+
+type name_info =
+  { ni_hostname : string;               (** Name or IP address of host *)
+    ni_service : string }               (** Name of service or port number *)
+(** Host and service information returned by {!Unix.getnameinfo}. *)
+
+type getnameinfo_option =
+    NI_NOFQDN            (** Do not qualify local host names *)
+  | NI_NUMERICHOST       (** Always return host as IP address *)
+  | NI_NAMEREQD          (** Fail if host name cannot be determined *)
+  | NI_NUMERICSERV       (** Always return service as port number *)
+  | NI_DGRAM             (** Consider the service as UDP-based
+                             instead of the default TCP *)
+(** Options to {!Unix.getnameinfo}. *)
+
+val getnameinfo : sockaddr -> getnameinfo_option list -> name_info
+(** [getnameinfo addr opts] returns the host name and service name
+    corresponding to the socket address [addr].  [opts] is a possibly
+    empty list of options that governs how these names are obtained.
+    Raise [Not_found] if an error occurs. *)
 
 (** {6 Terminal interface} *)
 
diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h
index aef2f3cc..f6fe3ddf 100644
--- a/otherlibs/unix/unixsupport.h
+++ b/otherlibs/unix/unixsupport.h
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: unixsupport.h,v 1.6 2001/12/07 13:40:39 xleroy Exp $ */
+/* $Id: unixsupport.h,v 1.7 2004/02/14 10:21:23 xleroy Exp $ */
 
 #ifdef HAS_UNISTD
 #include <unistd.h>
@@ -23,3 +23,5 @@ extern void unix_error (int errcode, char * cmdname, value arg) Noreturn;
 extern void uerror (char * cmdname, value arg) Noreturn;
 
 #define UNIX_BUFFER_SIZE 16384
+
+#define DIR_Val(v) *((DIR **) &Field(v, 0))
diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c
index ad2cc9f7..c020229e 100644
--- a/otherlibs/unix/write.c
+++ b/otherlibs/unix/write.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: write.c,v 1.13 2001/12/07 13:40:39 xleroy Exp $ */
+/* $Id: write.c,v 1.13.6.3 2004/07/08 08:40:47 xleroy Exp $ */
 
 #include <errno.h>
 #include <string.h>
@@ -54,3 +54,34 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
   End_roots();
   return Val_long(written);
 }
+
+/* When an error occurs after the first loop, unix_write reports the
+   error and discards the number of already written characters.
+   In this case, it would be better to discard the error and return the
+   number of bytes written, since most likely, unix_write will be call again,
+   and the error will be reproduced and this time will be reported.
+   This problem is avoided in unix_single_write, which is faithful to the
+   Unix system call. */
+
+CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) 
+{
+  long ofs, len;
+  int numbytes, ret;
+  char iobuf[UNIX_BUFFER_SIZE];
+
+  Begin_root (buf);
+    ofs = Long_val(vofs);
+    len = Long_val(vlen);
+    ret = 0;
+    if (len > 0) {
+      numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
+      memmove (iobuf, &Byte(buf, ofs), numbytes);
+      enter_blocking_section();
+      ret = write(Int_val(fd), iobuf, numbytes);
+      leave_blocking_section();
+      if (ret == -1) uerror("single_write", Nothing);
+    }
+  End_roots();
+  return Val_int(ret);
+}
+
diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt
index 902e5b19..06a38b38 100644
--- a/otherlibs/win32graph/Makefile.nt
+++ b/otherlibs/win32graph/Makefile.nt
@@ -11,7 +11,7 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt,v 1.5 2002/06/27 11:36:02 xleroy Exp $
+# $Id: Makefile.nt,v 1.5.6.1 2004/06/21 15:31:58 xleroy Exp $
 
 include ../../config/Makefile
 
@@ -22,7 +22,7 @@ CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib
 CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib
 COMPFLAGS=-warn-error A
 
-COBJS=open.$(O) draw.$(O) dib.$(O)
+COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O)
 CAMLOBJS=graphics.cmo
 WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32)
 
diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c
index fc2666f5..cf47fab3 100644
--- a/otherlibs/win32graph/draw.c
+++ b/otherlibs/win32graph/draw.c
@@ -10,14 +10,16 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: draw.c,v 1.7 2003/07/07 13:17:41 xleroy Exp $ */
+/* $Id: draw.c,v 1.9.2.2 2004/06/21 15:44:56 xleroy Exp $ */
 
 #include <math.h>
 #include "mlvalues.h"
 #include "alloc.h"
+#include "fail.h"
 #include "libgraph.h"
 #include "custom.h"
 #include "memory.h"
+
 HDC gcMetaFile;
 int grdisplay_mode;
 int grremember_mode;
@@ -32,7 +34,7 @@ static void GetCurrentPosition(HDC hDC,POINT *pt)
 static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry,
 				 value vstart, value vend, BOOL fill);
 
-CAMLprim value gr_plot(value vx, value vy)
+CAMLprim value caml_gr_plot(value vx, value vy)
 {
         int x = Int_val(vx);
         int y = Int_val(vy);
@@ -45,7 +47,7 @@ CAMLprim value gr_plot(value vx, value vy)
         return Val_unit;
 }
 
-CAMLprim value gr_moveto(value vx, value vy)
+CAMLprim value caml_gr_moveto(value vx, value vy)
 {
         grwindow.grx = Int_val(vx);
         grwindow.gry = Int_val(vy);
@@ -56,17 +58,17 @@ CAMLprim value gr_moveto(value vx, value vy)
         return Val_unit;
 }
 
-CAMLprim value gr_current_x(void)
+CAMLprim value caml_gr_current_x(void)
 {
         return Val_int(grwindow.grx);
 }
 
-CAMLprim value gr_current_y(void)
+CAMLprim value caml_gr_current_y(void)
 {
         return Val_int(grwindow.gry);
 }
 
-CAMLprim value gr_lineto(value vx, value vy)
+CAMLprim value caml_gr_lineto(value vx, value vy)
 {
         int x = Int_val(vx);
         int y = Int_val(vy);
@@ -82,40 +84,20 @@ CAMLprim value gr_lineto(value vx, value vy)
         return Val_unit;
 }
 
-CAMLprim value gr_draw_rect(value vx, value vy, value vw, value vh)
+CAMLprim value caml_gr_draw_rect(value vx, value vy, value vw, value vh)
 {
-#if 0
-        int x = Int_val(vx);
-        int y = Int_val(vy);
-        int w = Int_val(vw);
-        int h = Int_val(vh);
-
-        gr_check_open();
-        if(grdisplay_mode) {
-                Rectangle(grwindow.gc,x, Wcvt(y) , x+w, Wcvt(y+h));
-        }
-        if(grremember_mode) {
-                Rectangle(grwindow.gcBitmap,x, Wcvt(y), x+w, Wcvt(h+y));
-        }
-        return Val_unit;
-#else
         int     x, y, w, h;
         POINT pt[5];
         x=Int_val(vx);
-        y=Int_val(vy);
+        y=Wcvt(Int_val(vy));
         w=Int_val(vw);
         h=Int_val(vh);
 
-        pt[0].x = x;
-        pt[0].y = Wcvt(y-1);
-        pt[1].x = x+w;
-        pt[1].y = pt[0].y;
-        pt[2].x = pt[1].x;
-        pt[2].y = Wcvt(y+h-1);
-        pt[3].x = pt[0].x;
-        pt[3].y = pt[2].y;
-        pt[4].x = pt[0].x;
-        pt[4].y = pt[0].y;
+        pt[0].x = x;         pt[0].y = y - h;
+	pt[1].x = x + w;     pt[1].y = y - h;
+	pt[2].x = x + w;     pt[2].y = y;
+	pt[3].x = x;         pt[3].y = y;
+	pt[4].x = x;         pt[4].y = y - h;
         if (grremember_mode) {
                 Polyline(grwindow.gcBitmap,pt, 5);
         }
@@ -123,10 +105,9 @@ CAMLprim value gr_draw_rect(value vx, value vy, value vw, value vh)
                 Polyline(grwindow.gc,pt, 5);
         }
         return Val_unit;
-#endif
 }
 
-CAMLprim value gr_draw_text(value text,value x)
+CAMLprim value caml_gr_draw_text(value text,value x)
 {
         POINT pt;
         int oldmode = SetBkMode(grwindow.gc,TRANSPARENT);
@@ -147,7 +128,7 @@ CAMLprim value gr_draw_text(value text,value x)
         return Val_unit;
 }
 
-CAMLprim value gr_fill_rect(value vx, value vy, value vw, value vh)
+CAMLprim value caml_gr_fill_rect(value vx, value vy, value vw, value vh)
 {
         int x = Int_val(vx);
         int y = Int_val(vy);
@@ -167,13 +148,13 @@ CAMLprim value gr_fill_rect(value vx, value vy, value vw, value vh)
         return Val_unit;
 }
 
-CAMLprim value gr_sound(value freq, value vdur)
+CAMLprim value caml_gr_sound(value freq, value vdur)
 {
         Beep(freq,vdur);
         return Val_unit;
 }
 
-CAMLprim value gr_point_color(value vx, value vy)
+CAMLprim value caml_gr_point_color(value vx, value vy)
 {
         int x = Int_val(vx);
         int y = Int_val(vy);
@@ -188,7 +169,7 @@ CAMLprim value gr_point_color(value vx, value vy)
         return Val_long((r<<16) + (g<<8) + b);
 }
 
-CAMLprim value gr_circle(value x,value y,value radius)
+CAMLprim value caml_gr_circle(value x,value y,value radius)
 {
         int left,top,right,bottom;
 
@@ -201,24 +182,24 @@ CAMLprim value gr_circle(value x,value y,value radius)
         return Val_unit;
 }
 
-CAMLprim value gr_set_window_title(value text)
+CAMLprim value caml_gr_set_window_title(value text)
 {
         SetWindowText(grwindow.hwnd,(char *)text);
         return Val_unit;
 }
 
-CAMLprim value gr_draw_arc(value *argv, int argc)
+CAMLprim value caml_gr_draw_arc(value *argv, int argc)
 {
   return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3],
 			     argv[4], argv[5], FALSE);
 }
 
-CAMLprim value gr_draw_arc_nat(vx, vy, vrx, vry, vstart, vend)
+CAMLprim value caml_gr_draw_arc_nat(vx, vy, vrx, vry, vstart, vend)
 {
   return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, FALSE);
 }
 
-CAMLprim value gr_set_line_width(value vwidth)
+CAMLprim value caml_gr_set_line_width(value vwidth)
 {
         int width = Int_val(vwidth);
         HPEN oldPen,newPen;
@@ -233,7 +214,7 @@ CAMLprim value gr_set_line_width(value vwidth)
         return Val_unit;
 }
 
-CAMLprim value gr_set_color(value vcolor)
+CAMLprim value caml_gr_set_color(value vcolor)
 {
         HBRUSH oldBrush, newBrush;
         LOGBRUSH lb;
@@ -322,7 +303,7 @@ static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry,
         return Val_unit;
 }
 
-CAMLprim value gr_show_bitmap(value filename,int x,int y)
+CAMLprim value caml_gr_show_bitmap(value filename,int x,int y)
 {
         AfficheBitmap(filename,grwindow.gcBitmap,x,Wcvt(y));
         AfficheBitmap(filename,grwindow.gc,x,Wcvt(y));
@@ -331,7 +312,7 @@ CAMLprim value gr_show_bitmap(value filename,int x,int y)
 
 
 
-CAMLprim value gr_get_mousex(void)
+CAMLprim value caml_gr_get_mousex(void)
 {
         POINT pt;
         GetCursorPos(&pt);
@@ -339,7 +320,7 @@ CAMLprim value gr_get_mousex(void)
         return pt.x;
 }
 
-CAMLprim value gr_get_mousey(void)
+CAMLprim value caml_gr_get_mousey(void)
 {
         POINT pt;
         GetCursorPos(&pt);
@@ -360,35 +341,35 @@ static void gr_font(char *fontname)
         }
 }
 
-CAMLprim value gr_set_font(value fontname)
+CAMLprim value caml_gr_set_font(value fontname)
 {
         gr_check_open();
         gr_font(String_val(fontname));
         return Val_unit;
 }
 
-CAMLprim value gr_set_text_size (value sz)
+CAMLprim value caml_gr_set_text_size (value sz)
 {
         return Val_unit;
 }
 
-CAMLprim value gr_draw_char(value chr)
+CAMLprim value caml_gr_draw_char(value chr)
 {
         char str[1];
         gr_check_open();
         str[0] = Int_val(chr);
-        gr_draw_text((value)str, 1);
+        caml_gr_draw_text((value)str, 1);
         return Val_unit;
 }
 
-CAMLprim value gr_draw_string(value str)
+CAMLprim value caml_gr_draw_string(value str)
 {
         gr_check_open();
-        gr_draw_text(str, string_length(str));
+        caml_gr_draw_text(str, string_length(str));
         return Val_unit;
 }
 
-CAMLprim value gr_text_size(value str)
+CAMLprim value caml_gr_text_size(value str)
 {
         SIZE extent;
         value res;
@@ -405,126 +386,7 @@ CAMLprim value gr_text_size(value str)
         return res;
 }
 
-#if 0
-static unsigned char gr_queue[SIZE_QUEUE];
-static int gr_head = 0;       /* position of next read */
-static int gr_tail = 0;       /* position of next write */
-
-#define QueueIsEmpty (gr_head == gr_tail)
-#define QueueIsFull  (gr_head == gr_tail + 1)
-
-void gr_enqueue_char(unsigned char c)
-{
-        if (QueueIsFull) return;
-        gr_queue[gr_tail] = c;
-        gr_tail++;
-        if (gr_tail >= SIZE_QUEUE) gr_tail = 0;
-}
-#endif
-
-#define Button_down             1
-#define Button_up               2
-#define Key_pressed             4
-#define Mouse_motion    8
-#define Poll                    16
-MSG * InspectMessages = NULL;
-
-CAMLprim value gr_wait_event(value eventlist)
-{
-        value res;
-        int mask;
-        BOOL poll;
-        int mouse_x, mouse_y, button, key;
-        int root_x, root_y, win_x, win_y;
-        int r,i,stop;
-        unsigned int modifiers;
-        POINT pt;
-        MSG msg;
-
-        gr_check_open();
-        mask = 0;
-        poll = FALSE;
-        while (eventlist != Val_int(0)) {
-                switch (Int_val(Field(eventlist,0))) {
-                case 0:                     /* Button_down */
-                        mask |= Button_down;
-                        break;
-                case 1:                     /* Button_up */
-                        mask |= Button_up;
-                        break;
-                case 2:                     /* Key_pressed */
-                        mask |= Key_pressed;
-                        break;
-                case 3:                     /* Mouse_motion */
-                        mask |= Mouse_motion;
-                        break;
-                case 4:                     /* Poll */
-                        poll = TRUE;
-                        break;
-                }
-                eventlist = Field(eventlist,1);
-        }
-        mouse_x = -1;
-        mouse_y = -1;
-        button = 0;
-        key = -1;
-
-        if (poll) {
-                // Poll uses info on last event stored in global variables
-                mouse_x = MouseLastX;
-                mouse_y = MouseLastY;
-                button = MouseLbuttonDown | MouseMbuttonDown | MouseRbuttonDown;
-                key = LastKey;
-        }
-        else { // Not polled. Block for a message
-                InspectMessages = &msg;
-                do {
-                        WaitForSingleObject(EventHandle,INFINITE);
-                        stop = 0;
-                        switch (msg.message) {
-                        case WM_LBUTTONDOWN:
-                        case WM_MBUTTONDOWN:
-                        case WM_RBUTTONDOWN:
-                                button = 1;
-                                if (mask&Button_down) stop = 1;
-                                break;
-                        case WM_LBUTTONUP:
-                        case WM_MBUTTONUP:
-                        case WM_RBUTTONUP:
-                                button = 0;
-                                if (mask&Button_up) stop = 1;
-                                break;
-                        case WM_MOUSEMOVE:
-                                if (mask&Mouse_motion) stop = 1;
-                                break;
-                        case WM_CHAR:
-                                key = msg.wParam & 0xFF;
-                                if (mask&Key_pressed) stop = 1;
-                                break;
-			case WM_CLOSE:
-			        stop = 1;
-				break;
-                        }
-                        if (stop) {
-                                pt = msg.pt;
-                                MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1);
-                                mouse_x = pt.x;
-                                mouse_y = grwindow.height- 1 - pt.y;
-                        }
-			SetEvent(EventProcessedHandle);
-                } while (! stop);
-                InspectMessages = NULL;
-        }
-        res = alloc_small(5, 0);
-        Field(res, 0) = Val_int(mouse_x);
-        Field(res, 1) = Val_int(mouse_y);
-        Field(res, 2) = Val_bool(button);
-        Field(res, 3) = Val_bool(key != -1);
-        Field(res, 4) = Val_int(key & 0xFF);
-        return res;
-}
-
-CAMLprim value gr_fill_poly(value vect)
+CAMLprim value caml_gr_fill_poly(value vect)
 {
         int n_points, i;
         POINT   *p,*poly;
@@ -553,13 +415,13 @@ CAMLprim value gr_fill_poly(value vect)
         return Val_unit;
 }
 
-CAMLprim value gr_fill_arc(value *argv, int argc)
+CAMLprim value caml_gr_fill_arc(value *argv, int argc)
 {
   return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3],
 			     argv[4], argv[5], TRUE);
 }
 
-CAMLprim value gr_fill_arc_nat(vx, vy, vrx, vry, vstart, vend)
+CAMLprim value caml_gr_fill_arc_nat(vx, vy, vrx, vry, vstart, vend)
 {
   return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, TRUE);
 }
@@ -593,7 +455,7 @@ static struct custom_operations image_ops = {
         custom_deserialize_default
 };
 
-CAMLprim value gr_create_image(value vw, value vh)
+CAMLprim value caml_gr_create_image(value vw, value vh)
 {
         HBITMAP cbm;
         value res;
@@ -615,7 +477,7 @@ CAMLprim value gr_create_image(value vw, value vh)
         return res;
 }
 
-CAMLprim value gr_blit_image (value i, value x, value y)
+CAMLprim value caml_gr_blit_image (value i, value x, value y)
 {
         HBITMAP oldBmp = SelectObject(grwindow.tempDC,Data(i));
         int xsrc = Int_val(x);
@@ -627,7 +489,7 @@ CAMLprim value gr_blit_image (value i, value x, value y)
 }
 
 
-CAMLprim value gr_draw_image(value i, value x, value y)
+CAMLprim value caml_gr_draw_image(value i, value x, value y)
 {
         HBITMAP oldBmp;
 
@@ -671,7 +533,7 @@ CAMLprim value gr_draw_image(value i, value x, value y)
         return Val_unit;
 }
 
-CAMLprim value gr_make_image(value matrix)
+CAMLprim value caml_gr_make_image(value matrix)
 {
         int width, height,has_transp,i,j;
         value img;
@@ -688,7 +550,7 @@ CAMLprim value gr_make_image(value matrix)
                 }
         }
         Begin_roots1(matrix)
-                img = gr_create_image(Val_int(width), Val_int(height));
+                img = caml_gr_create_image(Val_int(width), Val_int(height));
         End_roots();
         has_transp = 0;
         oldBmp = SelectObject(grwindow.tempDC,Data(img));
@@ -742,7 +604,7 @@ static value alloc_int_vect(mlsize_t size)
         return res;
 }
 
-CAMLprim value gr_dump_image (value img)
+CAMLprim value caml_gr_dump_image (value img)
 {
         int height = Height(img);
         int width = Width(img);
diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c
new file mode 100755
index 00000000..a3fa5894
--- /dev/null
+++ b/otherlibs/win32graph/events.c
@@ -0,0 +1,200 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2004 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All 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.1.2.1 2004/06/21 15:31:58 xleroy Exp $ */
+
+#include "mlvalues.h"
+#include "alloc.h"
+#include "libgraph.h"
+#include <windows.h>
+
+enum {
+  EVENT_BUTTON_DOWN = 1,
+  EVENT_BUTTON_UP = 2,
+  EVENT_KEY_PRESSED = 4,
+  EVENT_MOUSE_MOTION = 8
+};
+
+struct event_data {
+  short mouse_x, mouse_y;
+  unsigned char kind;
+  unsigned char button;
+  unsigned char key;
+};
+
+static struct event_data caml_gr_queue[SIZE_QUEUE];
+static unsigned int caml_gr_head = 0;       /* position of next read */
+static unsigned int caml_gr_tail = 0;       /* position of next write */
+
+static int caml_gr_event_mask = EVENT_KEY_PRESSED;
+static int last_button = 0;
+static LPARAM last_pos = 0;
+
+HANDLE caml_gr_queue_semaphore = NULL;
+CRITICAL_SECTION caml_gr_queue_mutex;
+
+void caml_gr_init_event_queue(void)
+{
+  if (caml_gr_queue_semaphore == NULL) {
+    caml_gr_queue_semaphore = CreateSemaphore(NULL, 0, SIZE_QUEUE, NULL);
+    InitializeCriticalSection(&caml_gr_queue_mutex);
+  }
+}
+
+#define QueueIsEmpty (caml_gr_tail == caml_gr_head)
+
+static void caml_gr_enqueue_event(int kind, LPARAM mouse_xy,
+                                  int button, int key)
+{
+  struct event_data * ev;
+
+  if ((caml_gr_event_mask & kind) == 0) return;
+  EnterCriticalSection(&caml_gr_queue_mutex);
+  ev = &(caml_gr_queue[caml_gr_tail]);
+  ev->kind = kind;
+  ev->mouse_x = GET_X_LPARAM(mouse_xy);
+  ev->mouse_y = GET_Y_LPARAM(mouse_xy);
+  ev->button = (button != 0);
+  ev->key = key;
+  caml_gr_tail = (caml_gr_tail + 1) % SIZE_QUEUE;
+  /* If queue was full, it now appears empty;
+     drop oldest entry from queue. */
+  if (QueueIsEmpty) {
+    caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE;
+  } else {
+    /* One more event in queue */
+    ReleaseSemaphore(caml_gr_queue_semaphore, 1, NULL);
+  }
+  LeaveCriticalSection(&caml_gr_queue_mutex);
+}
+
+void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam)
+{
+  switch (msg) {
+  case WM_LBUTTONDOWN:
+  case WM_RBUTTONDOWN:
+  case WM_MBUTTONDOWN:
+    last_button = 1;
+    last_pos = lParam;
+    caml_gr_enqueue_event(EVENT_BUTTON_DOWN, lParam, 1, 0);
+    break;
+
+  case WM_LBUTTONUP:
+  case WM_RBUTTONUP:
+  case WM_MBUTTONUP:
+    last_button = 0;
+    last_pos = lParam;
+    caml_gr_enqueue_event(EVENT_BUTTON_UP, lParam, 0, 0);
+    break;
+
+  case WM_CHAR:
+    caml_gr_enqueue_event(EVENT_KEY_PRESSED, last_pos, last_button, wParam);
+    break;
+
+  case WM_MOUSEMOVE:
+    last_pos = lParam;
+    caml_gr_enqueue_event(EVENT_MOUSE_MOTION, lParam, last_button, 0);
+    break;
+  }
+}
+
+static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y,
+                                          int button,
+                                          int keypressed, int key)
+{
+  value res = alloc_small(5, 0);
+  Field(res, 0) = Val_int(mouse_x);
+  Field(res, 1) = Val_int(grwindow.height - 1 - mouse_y);
+  Field(res, 2) = Val_bool(button);
+  Field(res, 3) = Val_bool(keypressed);
+  Field(res, 4) = Val_int(key & 0xFF);
+  return res;
+}
+
+static value caml_gr_wait_event_poll(void)
+{
+  int key, keypressed, i;
+
+  /* Look inside event queue for pending KeyPress events */
+  EnterCriticalSection(&caml_gr_queue_mutex);
+  key = 0;
+  keypressed = 0;
+  for (i = caml_gr_head; i != caml_gr_tail; i = (i + 1) % SIZE_QUEUE) {
+    if (caml_gr_queue[i].kind == EVENT_KEY_PRESSED) {
+      keypressed = 1;
+      key = caml_gr_queue[i].key;
+      break;
+    }
+  }
+  LeaveCriticalSection(&caml_gr_queue_mutex);
+  /* Use global vars for mouse position and buttons */
+  return caml_gr_wait_allocate_result(GET_X_LPARAM(last_pos),
+                                      GET_Y_LPARAM(last_pos),
+                                      last_button,
+                                      keypressed, key);
+}
+
+static value caml_gr_wait_event_blocking(int mask)
+{
+  struct event_data ev;
+
+  /* Increase the selected events if needed */
+  caml_gr_event_mask |= mask;
+  /* Pop events from queue until one matches */
+  do {
+    /* Wait for event queue to be non-empty */
+    WaitForSingleObject(caml_gr_queue_semaphore, INFINITE);
+    /* Pop oldest event in queue */
+    EnterCriticalSection(&caml_gr_queue_mutex);
+    ev = caml_gr_queue[caml_gr_head];
+    /* Queue should never be empty at this point, but just in case... */
+    if (QueueIsEmpty) {
+      ev.kind = 0;
+    } else {
+      caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE;
+    }
+    LeaveCriticalSection(&caml_gr_queue_mutex);
+    /* Check if it matches */
+  } while ((ev.kind & mask) == 0);
+  return caml_gr_wait_allocate_result(ev.mouse_x, ev.mouse_y, ev.button,
+                                      ev.kind == EVENT_KEY_PRESSED,
+                                      ev.key);
+}
+
+CAMLprim value caml_gr_wait_event(value eventlist) /* ML */
+{
+  int mask, poll;
+
+  gr_check_open();
+  mask = 0;
+  poll = 0;
+  while (eventlist != Val_int(0)) {
+    switch (Int_val(Field(eventlist, 0))) {
+    case 0:                     /* Button_down */
+      mask |= EVENT_BUTTON_DOWN; break;
+    case 1:                     /* Button_up */
+      mask |= EVENT_BUTTON_UP; break;
+    case 2:                     /* Key_pressed */
+      mask |= EVENT_KEY_PRESSED; break;
+    case 3:                     /* Mouse_motion */
+      mask |= EVENT_MOUSE_MOTION; break;
+    case 4:                     /* Poll */
+      poll = 1; break;
+    }
+    eventlist = Field(eventlist, 1);
+  }
+  if (poll)
+    return caml_gr_wait_event_poll();
+  else
+    return caml_gr_wait_event_blocking(mask);
+}
diff --git a/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h
index 9da15a3d..0a702ccd 100644
--- a/otherlibs/win32graph/libgraph.h
+++ b/otherlibs/win32graph/libgraph.h
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: libgraph.h,v 1.7 2003/07/07 13:17:41 xleroy Exp $ */
+/* $Id: libgraph.h,v 1.8.2.1 2004/06/21 15:31:58 xleroy Exp $ */
 
 #include <stdio.h>
 #include <windows.h>
@@ -45,14 +45,11 @@ extern int bits_per_pixel;
 #define BORDER_WIDTH 2
 #define WINDOW_NAME "Caml graphics"
 #define ICON_NAME "Caml graphics"
-#define DEFAULT_EVENT_MASK \
-          (ExposureMask | KeyPressMask | StructureNotifyMask)
-#define DEFAULT_FONT "fixed"
 #define SIZE_QUEUE 256
 
 void gr_fail(char *fmt, char *arg);
 void gr_check_open(void);
-CAMLprim value gr_set_color(value vcolor);
+CAMLprim value caml_gr_set_color(value vcolor);
 
 // Windows specific definitions
 extern RECT WindowRect;
@@ -77,10 +74,5 @@ typedef struct tagWindow {
 
 extern GR_WINDOW grwindow;
 HFONT CreationFont(char *name);
-extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-extern HANDLE EventHandle, EventProcessedHandle;
-extern MSG * InspectMessages;
-extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-extern int MouseLastX, MouseLastY;
-extern int LastKey;
-
+extern void caml_gr_init_event_queue(void);
+extern void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam);
diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c
index efee37f1..5ec89247 100644
--- a/otherlibs/win32graph/open.c
+++ b/otherlibs/win32graph/open.c
@@ -10,17 +10,16 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: open.c,v 1.7 2003/07/07 13:17:41 xleroy Exp $ */
+/* $Id: open.c,v 1.8.2.2 2004/06/21 15:44:17 xleroy Exp $ */
 
 #include <fcntl.h>
 #include <signal.h>
 #include "mlvalues.h"
+#include "fail.h"
 #include "libgraph.h"
 #include <windows.h>
+
 static value gr_reset(void);
-int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-int MouseLastX, MouseLastY;
-int LastKey = -1;
 static long tid;
 static HANDLE threadHandle;
 HWND grdisplay = NULL;
@@ -36,11 +35,11 @@ int grcolor;
 extern HFONT * grfont;
 MSG msg;
 
-HANDLE EventHandle, EventProcessedHandle;
 static char *szOcamlWindowClass = "OcamlWindowClass";
 static BOOL gr_initialized = 0;
-CAMLprim value gr_clear_graph(void);
+CAMLprim value caml_gr_clear_graph(void);
 HANDLE hInst;
+
 HFONT CreationFont(char *name)
 {
    LOGFONT CurrentFont;
@@ -65,8 +64,11 @@ void SetCoordinates(HWND hwnd)
 
 void ResetForClose(HWND hwnd)
 {
+        DeleteDC(grwindow.tempDC);
+        DeleteDC(grwindow.gcBitmap);
         DeleteObject(grwindow.hBitmap);
         memset(&grwindow,0,sizeof(grwindow));
+        gr_initialized = 0;
 }
 
         
@@ -98,44 +100,9 @@ static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM
         case WM_DESTROY:
                 ResetForClose(hwnd);
                 break;
-        case WM_LBUTTONDOWN:
-                MouseLbuttonDown = 1;
-                break;
-        case WM_LBUTTONUP:
-                MouseLbuttonDown = 0;
-                break;
-        case WM_RBUTTONDOWN:
-                MouseRbuttonDown = 1;
-                break;
-        case WM_RBUTTONUP:
-                MouseRbuttonDown = 0;
-                break;
-        case WM_MBUTTONDOWN:
-                MouseMbuttonDown = 1;
-                break;
-        case WM_MBUTTONUP:
-                MouseMbuttonDown = 0;
-                break;
-        case WM_CHAR:
-                LastKey = wParam & 0xFF;
-                break;
-        case WM_KEYUP:
-                LastKey = -1;
-                break;
-        case WM_MOUSEMOVE:
-#if 0
-                pt.x = GET_X_LPARAM(lParam);
-                pt.y = GET_Y_LPARAM(lParam);
-                MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1);
-                MouseLastX = pt.x;
-                MouseLastY = grwindow.height - 1 - pt.y;
-#else
-                MouseLastX = GET_X_LPARAM(lParam);
-                MouseLastY = grwindow.height - 1 - GET_Y_LPARAM(lParam);
-#endif
-                break;
         }
-        return DefWindowProc(hwnd,msg,wParam,lParam);
+        caml_gr_handle_event(msg, wParam, lParam);
+        return DefWindowProc(hwnd, msg, wParam, lParam);
 }
 
 int DoRegisterClass(void)
@@ -186,7 +153,7 @@ static value gr_reset(void)
         grwindow.CurrentBrush = SelectObject(grwindow.gc,GetStockObject(WHITE_BRUSH));
         SelectObject(grwindow.gc,grwindow.CurrentBrush);
         SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush);
-	gr_set_color(Val_long(0));
+	caml_gr_set_color(Val_long(0));
         SelectObject(grwindow.gc,grwindow.CurrentFont);
         SelectObject(grwindow.gcBitmap,grwindow.CurrentFont);
         grdisplay_mode = grremember_mode = 1;
@@ -266,8 +233,7 @@ static DWORD WINAPI gr_open_graph_internal(value arg)
   grwindow.grx = 0;
   grwindow.gry = 0;
   
-  EventHandle = CreateEvent(NULL,0,0,NULL);
-  EventProcessedHandle = CreateEvent(NULL,0,0,NULL);
+  caml_gr_init_event_queue();
 
   /* The global data structures are now correctly initialized.
      Restart the Caml main thread. */
@@ -276,22 +242,15 @@ static DWORD WINAPI gr_open_graph_internal(value arg)
 
   /* Enter the message handling loop */
   while (GetMessage(&msg,NULL,0,0)) {
-    if (InspectMessages != NULL) {
-      *InspectMessages = msg;
-      SetEvent(EventHandle);
-    }
     TranslateMessage(&msg);  // Translates virtual key codes
     DispatchMessage(&msg);   // Dispatches message to window
     if (!IsWindow(grwindow.hwnd))
       break;
-    if (InspectMessages != NULL) {
-      WaitForSingleObject(EventProcessedHandle,INFINITE);
-    }
   }
   return 0;
 }
 
-CAMLprim value gr_open_graph(value arg)
+CAMLprim value caml_gr_open_graph(value arg)
 {
   long tid;
   if (gr_initialized) return Val_unit;
@@ -307,19 +266,16 @@ CAMLprim value gr_open_graph(value arg)
   return Val_unit;
 }
 
-CAMLprim value gr_close_graph(void)
+CAMLprim value caml_gr_close_graph(void)
 {
         if (gr_initialized) {
-                DeleteDC(grwindow.tempDC);
-                DeleteDC(grwindow.gcBitmap);
-                DestroyWindow(grwindow.hwnd);
-                memset(&grwindow,0,sizeof(grwindow));
-                gr_initialized = 0;
+	        PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0);
+                WaitForSingleObject(threadHandle, INFINITE);
         }
         return Val_unit;
 }
 
-CAMLprim value gr_clear_graph(void)
+CAMLprim value caml_gr_clear_graph(void)
 {
         gr_check_open();
         if(grremember_mode) {
@@ -333,19 +289,19 @@ CAMLprim value gr_clear_graph(void)
         return Val_unit;
 }
 
-CAMLprim value gr_size_x(void)
+CAMLprim value caml_gr_size_x(void)
 {
         gr_check_open();
         return Val_int(grwindow.width);
 }
 
-CAMLprim value gr_size_y(void)
+CAMLprim value caml_gr_size_y(void)
 {
         gr_check_open();
         return Val_int(grwindow.height);
 }
 
-CAMLprim value gr_synchronize(void)
+CAMLprim value caml_gr_synchronize(void)
 {
         gr_check_open();
         BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height,
@@ -353,24 +309,24 @@ CAMLprim value gr_synchronize(void)
         return Val_unit ;
 }
 
-CAMLprim value gr_display_mode(value flag)
+CAMLprim value caml_gr_display_mode(value flag)
 {
         grdisplay_mode =  (Int_val(flag)) ? 1 : 0;
         return Val_unit ;
 }
 
-CAMLprim value gr_remember_mode(value flag)
+CAMLprim value caml_gr_remember_mode(value flag)
 {
         grremember_mode = (Int_val(flag)) ? 1 : 0;
         return Val_unit ;
 }
 
-CAMLprim value gr_sigio_signal(value unit)
+CAMLprim value caml_gr_sigio_signal(value unit)
 {
         return Val_unit;
 }
 
-CAMLprim value gr_sigio_handler(void)
+CAMLprim value caml_gr_sigio_handler(void)
 {
         return Val_unit;
 }
diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt
index 04b7eaae..4adc01a9 100644
--- a/otherlibs/win32unix/Makefile.nt
+++ b/otherlibs/win32unix/Makefile.nt
@@ -11,7 +11,7 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt,v 1.31 2003/01/06 16:44:21 xleroy Exp $
+# $Id: Makefile.nt,v 1.32 2004/05/30 08:17:06 xleroy Exp $
 
 include ../../config/Makefile
 
@@ -82,7 +82,7 @@ clean: partialclean
 install:
 	cp dllunix.dll $(STUBLIBDIR)/dllunix.dll
 	cp libunix.$(A) $(LIBDIR)/libunix.$(A)
-	cp $(CAML_OBJS:.cmo=.cmi) unix.cma $(LIBDIR)
+	cp $(CAML_OBJS:.cmo=.cmi) unix.cma $(CAML_OBJS:.cmo=.mli) $(LIBDIR)
 
 installopt:
 	cp unix.cmxa $(CAML_OBJS:.cmo=.cmx) unix.$(A) $(LIBDIR)
diff --git a/otherlibs/win32unix/errmsg.c b/otherlibs/win32unix/errmsg.c
index 20a8c8d5..ba7eb3c3 100644
--- a/otherlibs/win32unix/errmsg.c
+++ b/otherlibs/win32unix/errmsg.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id$ */
+/* $Id: errmsg.c,v 1.5 2003/12/31 00:00:14 doligez Exp $ */
 
 #include <stdio.h>
 #include <errno.h>
diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c
index e750505f..f20a2e2f 100644
--- a/otherlibs/win32unix/rename.c
+++ b/otherlibs/win32unix/rename.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: rename.c,v 1.2 2002/07/23 14:12:01 doligez Exp $ */
+/* $Id: rename.c,v 1.2.8.1 2004/06/21 16:18:32 xleroy Exp $ */
 
 #include <stdio.h>
 #include <mlvalues.h>
@@ -19,9 +19,23 @@
 
 CAMLprim value unix_rename(value path1, value path2)
 {
-  if (MoveFileEx(String_val(path1), String_val(path2),
-                 MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH |
-                 MOVEFILE_COPY_ALLOWED) == 0) {
+  static int supports_MoveFileEx = -1; /* don't know yet */
+  BOOL ok;
+
+  if (supports_MoveFileEx < 0) {
+    OSVERSIONINFO VersionInfo;
+    VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+    supports_MoveFileEx =
+      (GetVersionEx(&VersionInfo) != 0)
+      && (VersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT);
+  }
+  if (supports_MoveFileEx > 0)
+    ok = MoveFileEx(String_val(path1), String_val(path2),
+		    MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH |
+		    MOVEFILE_COPY_ALLOWED);
+  else
+    ok = MoveFile(String_val(path1), String_val(path2));
+  if (! ok) {
     win32_maperr(GetLastError());
     uerror("rename", path1);
   }     
diff --git a/otherlibs/win32unix/socketaddr.h b/otherlibs/win32unix/socketaddr.h
index 8b9d3821..8e0d2548 100644
--- a/otherlibs/win32unix/socketaddr.h
+++ b/otherlibs/win32unix/socketaddr.h
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: socketaddr.h,v 1.6 2002/04/30 15:00:47 xleroy Exp $ */
+/* $Id: socketaddr.h,v 1.7 2004/04/27 13:49:50 xleroy Exp $ */
 
 #include <misc.h>
 
@@ -28,11 +28,10 @@ typedef socklen_t socklen_param_type;
 typedef int socklen_param_type;
 #endif
 
-void get_sockaddr (value mladdr,
-                   union sock_addr_union * addr /*out*/,
-                   socklen_param_type * addr_len /*out*/);
-value alloc_sockaddr (union sock_addr_union * addr /*in*/,
+extern void get_sockaddr (value mladdr,
+                          union sock_addr_union * addr /*out*/,
+                          socklen_param_type * addr_len /*out*/);
+CAMLprim value alloc_sockaddr (union sock_addr_union * addr /*in*/,
                       socklen_param_type addr_len);
-value alloc_inet_addr (uint32 inaddr);
-
-#define GET_INET_ADDR(v) (*((uint32 *) (v)))
+CAMLprim value alloc_inet_addr (struct in_addr * inaddr);
+#define GET_INET_ADDR(v) (*((struct in_addr *) (v)))
diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index 389de9fd..b3d35f5c 100644
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unix.ml,v 1.37 2003/01/06 16:44:21 xleroy Exp $ *)
+(* $Id: unix.ml,v 1.41.2.1 2004/06/22 17:18:50 remy Exp $ *)
 
 (* Initialization *)
 
@@ -121,7 +121,7 @@ let handle_unix_error f arg =
     exit 2
 
 external environment : unit -> string array = "unix_environment"
-external getenv: string -> string = "sys_getenv"
+external getenv: string -> string = "caml_sys_getenv"
 external putenv: string -> string -> unit = "unix_putenv"
 
 type process_status =
@@ -135,10 +135,10 @@ type wait_flag =
 
 type file_descr
 
-external execv : string -> string array -> unit = "unix_execv"
-external execve : string -> string array -> string array -> unit = "unix_execve"
-external execvp : string -> string array -> unit = "unix_execvp"
-external execvpe : string -> string array -> string array -> unit = "unix_execvpe"
+external execv : string -> string array -> 'a = "unix_execv"
+external execve : string -> string array -> string array -> 'a = "unix_execve"
+external execvp : string -> string array -> 'a = "unix_execvp"
+external execvpe : string -> string array -> string array -> 'a = "unix_execvpe"
 
 external waitpid : wait_flag list -> int -> int * process_status
                  = "win_waitpid"
@@ -180,6 +180,8 @@ external unsafe_read : file_descr -> string -> int -> int -> int
                      = "unix_read"
 external unsafe_write : file_descr -> string -> int -> int -> int
                       = "unix_write"
+external unsafe_single_write : file_descr -> string -> int -> int -> int
+                      = "unix_single_write"
 
 let read fd buf ofs len =
   if ofs < 0 || len < 0 || ofs > String.length buf - len
@@ -189,13 +191,18 @@ let write fd buf ofs len =
   if ofs < 0 || len < 0 || ofs > String.length buf - len
   then invalid_arg "Unix.write"
   else unsafe_write fd buf ofs len
+let single_write fd buf ofs len =
+  if ofs < 0 || len < 0 || ofs > String.length buf - len
+  then invalid_arg "Unix.single_write"
+  else unsafe_single_write fd buf ofs len
 
 (* Interfacing with the standard input/output library *)
 
-external open_read_descriptor : int -> in_channel = "caml_open_descriptor_in"
-external open_write_descriptor : int -> out_channel = "caml_open_descriptor_out"
-external fd_of_in_channel : in_channel -> int = "channel_descriptor"
-external fd_of_out_channel : out_channel -> int = "channel_descriptor"
+external open_read_descriptor : int -> in_channel = "caml_ml_open_descriptor_in"
+external open_write_descriptor : int -> out_channel
+                               = "caml_ml_open_descriptor_out"
+external fd_of_in_channel : in_channel -> int = "caml_channel_descriptor"
+external fd_of_out_channel : out_channel -> int = "caml_channel_descriptor"
 
 external open_handle : file_descr -> int = "win_fd_handle"
 
@@ -463,7 +470,9 @@ let getgrgid = getpwnam
 
 (* Internet addresses *)
 
-type inet_addr
+type inet_addr = string
+
+let is_inet6_addr s = String.length s = 16
 
 external inet_addr_of_string : string -> inet_addr
                                     = "unix_inet_addr_of_string"
@@ -471,12 +480,18 @@ external string_of_inet_addr : inet_addr -> string
                                     = "unix_string_of_inet_addr"
 
 let inet_addr_any = inet_addr_of_string "0.0.0.0"
+let inet_addr_loopback = inet_addr_of_string "127.0.0.1"
+let inet6_addr_any =
+  try inet_addr_of_string "::" with Failure _ -> inet_addr_any
+let inet6_addr_loopback =
+  try inet_addr_of_string "::1" with Failure _ -> inet_addr_loopback
 
 (* Sockets *)
 
 type socket_domain =
     PF_UNIX
   | PF_INET
+  | PF_INET6
 
 type socket_type =
     SOCK_STREAM
@@ -488,6 +503,10 @@ type sockaddr =
     ADDR_UNIX of string
   | ADDR_INET of inet_addr * int
 
+let domain_of_sockaddr = function
+    ADDR_UNIX _ -> PF_UNIX
+  | ADDR_INET(a, _) -> if is_inet6_addr a then PF_INET6 else PF_INET
+
 type shutdown_command =
     SHUTDOWN_RECEIVE
   | SHUTDOWN_SEND
@@ -611,18 +630,133 @@ external getservbyname : string -> string -> service_entry
 external getservbyport : int -> string -> service_entry
                                          = "unix_getservbyport"
 
+type addr_info =
+  { ai_family : socket_domain;
+    ai_socktype : socket_type;
+    ai_protocol : int;
+    ai_addr : sockaddr;
+    ai_canonname : string }
+
+type getaddrinfo_option =
+    AI_FAMILY of socket_domain
+  | AI_SOCKTYPE of socket_type
+  | AI_PROTOCOL of int
+  | AI_NUMERICHOST
+  | AI_CANONNAME
+  | AI_PASSIVE
+
+let getaddrinfo node service opts =
+  (* Parse options *)
+  let opt_socktype = ref None
+  and opt_protocol = ref 0
+  and opt_passive = ref false in
+  List.iter
+    (function AI_SOCKTYPE s -> opt_socktype := Some s
+            | AI_PROTOCOL p -> opt_protocol := p
+            | AI_PASSIVE -> opt_passive := true
+            | _ -> ())
+    opts;
+  (* Determine socket types and port numbers *)
+  let get_port ty kind =
+    if service = "" then [ty, 0] else
+      try
+        [ty, int_of_string service]
+      with Failure _ ->
+      try
+        [ty, (getservbyname service kind).s_port]
+      with Not_found -> [] 
+  in
+  let ports =
+    match !opt_socktype with
+    | None ->
+        get_port SOCK_STREAM "tcp" @ get_port SOCK_DGRAM "udp"
+    | Some SOCK_STREAM ->
+        get_port SOCK_STREAM "tcp"
+    | Some SOCK_DGRAM ->
+        get_port SOCK_DGRAM "udp"
+    | Some ty ->
+        if service = "" then [ty, 0] else [] in
+  (* Determine IP addresses *)
+  let addresses =
+    if node = "" then
+      if List.mem AI_PASSIVE opts
+      then [inet_addr_any, "0.0.0.0"]
+      else [inet_addr_loopback, "127.0.0.1"]
+    else
+      try
+        [inet_addr_of_string node, node]
+      with Failure _ ->
+      try
+        let he = gethostbyname node in
+        List.map
+          (fun a -> (a, he.h_name))
+          (Array.to_list he.h_addr_list)
+      with Not_found ->
+        [] in
+  (* Cross-product of addresses and ports *)
+  List.flatten
+    (List.map 
+      (fun (ty, port) ->
+        List.map
+          (fun (addr, name) ->
+            { ai_family = PF_INET;
+              ai_socktype = ty;
+              ai_protocol = !opt_protocol;
+              ai_addr = ADDR_INET(addr, port);
+              ai_canonname = name })
+          addresses)
+      ports)
+
+type name_info =
+  { ni_hostname : string;
+    ni_service : string }
+
+type getnameinfo_option =
+    NI_NOFQDN
+  | NI_NUMERICHOST
+  | NI_NAMEREQD
+  | NI_NUMERICSERV
+  | NI_DGRAM
+
+let getnameinfo addr opts =
+  match addr with
+  | ADDR_UNIX f ->
+      { ni_hostname = ""; ni_service = f } (* why not? *)
+  | ADDR_INET(a, p) ->
+      let hostname =
+        try
+          if List.mem NI_NUMERICHOST opts then raise Not_found;
+          (gethostbyaddr a).h_name
+        with Not_found ->
+          if List.mem NI_NAMEREQD opts then raise Not_found;
+          string_of_inet_addr a in
+      let service =
+        try
+          if List.mem NI_NUMERICSERV opts then raise Not_found;
+          let kind = if List.mem NI_DGRAM opts then "udp" else "tcp" in
+          (getservbyport p kind).s_name
+        with Not_found ->
+          string_of_int p in
+      { ni_hostname = hostname; ni_service = service }
+
 (* High-level process management (system, popen) *)
 
 external win_create_process : string -> string -> string option ->
                               file_descr -> file_descr -> file_descr -> int
                             = "win_create_process" "win_create_process_native"
 
+let make_cmdline args =
+  let maybe_quote f =
+    if String.contains f ' ' || String.contains f '\"'
+    then Filename.quote f
+    else f in
+  String.concat " " (List.map maybe_quote (Array.to_list args))
+
 let create_process prog args fd1 fd2 fd3 =
-  win_create_process prog (String.concat " " (Array.to_list args)) None
-                     fd1 fd2 fd3
+  win_create_process prog (make_cmdline args) None fd1 fd2 fd3
 
 let create_process_env prog args env fd1 fd2 fd3 =
-  win_create_process prog (String.concat " " (Array.to_list args))
+  win_create_process prog (make_cmdline args)
                      (Some(String.concat "\000" (Array.to_list env) ^ "\000"))
                      fd1 fd2 fd3 
 
diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c
index 0888c5fa..7b8ec035 100644
--- a/otherlibs/win32unix/unixsupport.c
+++ b/otherlibs/win32unix/unixsupport.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: unixsupport.c,v 1.18 2003/01/06 14:52:57 xleroy Exp $ */
+/* $Id: unixsupport.c,v 1.19 2004/04/01 13:12:36 xleroy Exp $ */
 
 #include <stddef.h>
 #include <mlvalues.h>
@@ -61,6 +61,7 @@ value win_alloc_socket(SOCKET s)
   value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1);
   Socket_val(res) = s;
   Descr_kind_val(res) = KIND_SOCKET;
+  CRT_fd_val(res) = NO_CRT_FD;
   return res;
 }
 
diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c
index d1de4dd8..250ae42c 100644
--- a/otherlibs/win32unix/write.c
+++ b/otherlibs/win32unix/write.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: write.c,v 1.7 2002/07/23 14:12:01 doligez Exp $ */
+/* $Id: write.c,v 1.7.6.2 2004/07/08 08:40:55 xleroy Exp $ */
 
 #include <errno.h>
 #include <string.h>
@@ -62,3 +62,44 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
   End_roots();
   return Val_long(written);
 }
+
+CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen)
+{
+  long ofs, len, written;
+  DWORD numbytes, numwritten;
+  char iobuf[UNIX_BUFFER_SIZE];
+
+  Begin_root (buf);
+    ofs = Long_val(vofs);
+    len = Long_val(vlen);
+    written = 0;
+    if (len > 0) {
+      numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
+      memmove (iobuf, &Byte(buf, ofs), numbytes);
+      if (Descr_kind_val(fd) == KIND_SOCKET) {
+        int ret;
+        SOCKET s = Socket_val(fd);
+        enter_blocking_section();
+        ret = send(s, iobuf, numbytes, 0);
+        leave_blocking_section();
+        if (ret == SOCKET_ERROR) {
+          win32_maperr(WSAGetLastError());
+          uerror("single_write", Nothing);
+        }
+        numwritten = ret;
+      } else {
+        BOOL ret;
+        HANDLE h = Handle_val(fd);
+        enter_blocking_section();
+        ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL);
+        leave_blocking_section();
+        if (! ret) {
+          win32_maperr(GetLastError());
+          uerror("single_write", Nothing);
+        }
+      }
+      written = numwritten;
+    }
+  End_roots();
+  return Val_long(written);
+}
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 05e8d1ba..2a2f7080 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer.mli,v 1.13 2002/11/01 17:06:46 doligez Exp $ *)
+(* $Id: lexer.mli,v 1.14 2003/11/21 16:01:13 xleroy Exp $ *)
 
 (* The lexical analyzer *)
 
@@ -24,6 +24,7 @@ type error =
   | Unterminated_string
   | Unterminated_string_in_comment
   | Keyword_as_label of string
+  | Literal_overflow of string
 ;;
 
 exception Error of error * Location.t
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 3f3a237a..4f756299 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer.mll,v 1.66 2003/08/25 13:15:47 doligez Exp $ *)
+(* $Id: lexer.mll,v 1.69 2004/01/16 15:24:02 doligez Exp $ *)
 
 (* The lexer definition *)
 
@@ -26,6 +26,7 @@ type error =
   | Unterminated_string
   | Unterminated_string_in_comment
   | Keyword_as_label of string
+  | Literal_overflow of string
 ;;
 
 exception Error of error * Location.t;;
@@ -124,25 +125,12 @@ let in_comment () = !comment_start_loc <> [];;
 
 (* To translate escape sequences *)
 
-let char_for_backslash =
-  match Sys.os_type with
-  | "Unix" | "Win32" | "Cygwin" ->
-      begin function
-      | 'n' -> '\010'
-      | 'r' -> '\013'
-      | 'b' -> '\008'
-      | 't' -> '\009'
-      | c   -> c
-      end
-  | "MacOS" ->
-      begin function
-      | 'n' -> '\013'
-      | 'r' -> '\010'
-      | 'b' -> '\008'
-      | 't' -> '\009'
-      | c   -> c
-      end
-  | x -> fatal_error "Lexer: unknown system type"
+let char_for_backslash = function
+  | 'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
 
 let char_for_decimal_code lexbuf i =
   let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
@@ -211,6 +199,8 @@ let report_error ppf = function
       fprintf ppf "This comment contains an unterminated string literal"
   | Keyword_as_label kwd ->
       fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
+  | Literal_overflow ty ->
+      fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty
 ;;
 
 }
@@ -271,19 +261,32 @@ rule token = parse
   | uppercase identchar *
       { UIDENT(Lexing.lexeme lexbuf) }       (* No capitalized keywords *)
   | int_literal
-      { INT (int_of_string(Lexing.lexeme lexbuf)) }
+      { try
+          INT (int_of_string(Lexing.lexeme lexbuf))
+        with Failure _ ->
+          raise (Error(Literal_overflow "int", Location.curr lexbuf))
+      }
   | float_literal
       { FLOAT (remove_underscores(Lexing.lexeme lexbuf)) }
   | int_literal "l"
       { let s = Lexing.lexeme lexbuf in
-        INT32 (Int32.of_string(String.sub s 0 (String.length s - 1))) }
+        try
+          INT32 (Int32.of_string(String.sub s 0 (String.length s - 1)))
+        with Failure _ ->
+          raise (Error(Literal_overflow "int32", Location.curr lexbuf)) }
   | int_literal "L"
       { let s = Lexing.lexeme lexbuf in
-        INT64 (Int64.of_string(String.sub s 0 (String.length s - 1))) }
+        try
+          INT64 (Int64.of_string(String.sub s 0 (String.length s - 1)))
+        with Failure _ ->
+          raise (Error(Literal_overflow "int64", Location.curr lexbuf)) }
   | int_literal "n"
       { let s = Lexing.lexeme lexbuf in
-        NATIVEINT 
-          (Nativeint.of_string(String.sub s 0 (String.length s - 1))) }
+        try
+          NATIVEINT 
+            (Nativeint.of_string(String.sub s 0 (String.length s - 1)))
+        with Failure _ ->
+          raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) }
   | "\""
       { reset_string_buffer();
         let string_start = lexbuf.lex_start_p in
@@ -357,6 +360,7 @@ rule token = parse
   | "["  { LBRACKET }
   | "[|" { LBRACKETBAR }
   | "[<" { LBRACKETLESS }
+  | "[>" { LBRACKETGREATER }
   | "]"  { RBRACKET }
   | "{"  { LBRACE }
   | "{<" { LBRACELESS }
diff --git a/parsing/location.ml b/parsing/location.ml
index d681dd90..a208d24c 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: location.ml,v 1.43 2003/09/03 13:24:56 doligez Exp $ *)
+(* $Id: location.ml,v 1.44 2004/01/16 15:24:02 doligez Exp $ *)
 
 open Lexing
 
@@ -189,9 +189,7 @@ let reset () =
   num_loc_lines := 0
 
 let (msg_file, msg_line, msg_chars, msg_to, msg_colon, msg_head) =
-  match Sys.os_type with
-  | "MacOS" -> ("File \"", "\"; line ", "; characters ", " to ", "", "### ")
-  | _ -> ("File \"", "\", line ", ", characters ", "-", ":", "")
+  ("File \"", "\", line ", ", characters ", "-", ":", "")
 
 (* return file, line, char from the given position *)
 let get_pos_info pos =
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 6fa9d6c5..63870408 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -10,7 +10,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: parser.mly,v 1.117 2003/08/25 13:15:47 doligez Exp $ */
+/* $Id: parser.mly,v 1.120 2004/05/19 12:15:19 doligez Exp $ */
 
 /* The parser definition */
 
@@ -245,6 +245,7 @@ let bigarray_set arr arg newval =
 %token LBRACKET
 %token LBRACKETBAR
 %token LBRACKETLESS
+%token LBRACKETGREATER
 %token LESS
 %token LESSMINUS
 %token LET
@@ -595,7 +596,7 @@ class_simple_expr:
   | OBJECT class_structure END
       { mkclass(Pcl_structure($2)) }
   | OBJECT class_structure error
-      { unclosed "class" 1 "end" 3 }
+      { unclosed "object" 1 "end" 3 }
   | LPAREN class_expr COLON class_type RPAREN
       { mkclass(Pcl_constraint($2, $4)) }
   | LPAREN class_expr COLON class_type error
@@ -689,7 +690,7 @@ class_signature:
   | OBJECT class_sig_body END
       { mkcty(Pcty_signature $2) }
   | OBJECT class_sig_body error
-      { unclosed "sig" 1 "end" 3 }
+      { unclosed "object" 1 "end" 3 }
 ;
 class_sig_body:
     class_self_type class_sig_fields
@@ -879,6 +880,10 @@ expr:
       { mkassert $2 }
   | LAZY simple_expr %prec below_SHARP
       { mkexp (Pexp_lazy ($2)) }
+  | OBJECT class_structure END
+      { mkexp (Pexp_object($2)) }
+  | OBJECT class_structure error
+      { unclosed "object" 1 "end" 3 }
 ;
 simple_expr:
     val_longident
@@ -920,7 +925,7 @@ simple_expr:
   | LBRACE record_expr RBRACE
       { let (exten, fields) = $2 in mkexp(Pexp_record(fields, exten)) }
   | LBRACE record_expr error
-      { unclosed "{" 1 "}" 5 }
+      { unclosed "{" 1 "}" 3 }
   | LBRACKETBAR expr_semi_list opt_semi BARRBRACKET
       { mkexp(Pexp_array(List.rev $2)) }
   | LBRACKETBAR expr_semi_list opt_semi error
@@ -1282,9 +1287,9 @@ simple_core_type2:
       { mktyp(Ptyp_variant(List.rev $3, true, None)) }
   | LBRACKET row_field BAR row_field_list RBRACKET
       { mktyp(Ptyp_variant($2 :: List.rev $4, true, None)) }
-  | LBRACKET GREATER opt_bar row_field_list RBRACKET
-      { mktyp(Ptyp_variant(List.rev $4, false, None)) }
-  | LBRACKET GREATER RBRACKET
+  | LBRACKETGREATER opt_bar row_field_list RBRACKET
+      { mktyp(Ptyp_variant(List.rev $3, false, None)) }
+  | LBRACKETGREATER RBRACKET
       { mktyp(Ptyp_variant([], false, None)) }
   | LBRACKETLESS opt_bar row_field_list RBRACKET
       { mktyp(Ptyp_variant(List.rev $3, true, Some [])) }
@@ -1314,7 +1319,7 @@ amper_type_list:
   | amper_type_list AMPERSAND core_type         { $3 :: $1 }
 ;
 opt_present:
-    LBRACKET GREATER name_tag_list RBRACKET     { List.rev $3 }
+    LBRACKETGREATER name_tag_list RBRACKET      { List.rev $2 }
   | /* empty */                                 { [] }
 ;
 name_tag_list:
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index c4a72d9c..c1c69beb 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parsetree.mli,v 1.39 2003/07/02 09:14:31 xleroy Exp $ *)
+(* $Id: parsetree.mli,v 1.40 2003/11/25 08:46:45 garrigue Exp $ *)
 
 (* Abstract syntax tree produced by parsing *)
 
@@ -110,6 +110,7 @@ and expression_desc =
   | Pexp_assertfalse
   | Pexp_lazy of expression
   | Pexp_poly of expression * core_type option
+  | Pexp_object of class_structure
 
 (* Value descriptions *)
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 9d337240..fbd981c9 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printast.ml,v 1.25 2003/07/02 09:14:31 xleroy Exp $ *)
+(* $Id: printast.ml,v 1.26 2003/11/25 08:46:45 garrigue Exp $ *)
 
 open Asttypes;;
 open Format;;
@@ -292,6 +292,9 @@ and expression i ppf x =
       line i ppf "Pexp_poly\n";
       expression i ppf e;
       option i core_type ppf cto;
+  | Pexp_object s ->
+      line i ppf "Pexp_object";
+      class_structure i ppf s
 
 and value_description i ppf x =
   line i ppf "value_description\n";
diff --git a/stdlib/.cvsignore b/stdlib/.cvsignore
index 55668783..1f035fa0 100644
--- a/stdlib/.cvsignore
+++ b/stdlib/.cvsignore
@@ -2,3 +2,4 @@ camlheader
 camlheader_ur
 labelled-*
 caml
+*.annot
diff --git a/stdlib/.depend b/stdlib/.depend
index c19afaa8..82a3ead4 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -1,3 +1,4 @@
+camlinternalOO.cmi: obj.cmi 
 format.cmi: buffer.cmi 
 genlex.cmi: stream.cmi 
 moreLabels.cmi: hashtbl.cmi map.cmi set.cmi 
@@ -16,10 +17,10 @@ buffer.cmo: string.cmi sys.cmi buffer.cmi
 buffer.cmx: string.cmx sys.cmx buffer.cmi 
 callback.cmo: obj.cmi callback.cmi 
 callback.cmx: obj.cmx callback.cmi 
-camlinternalOO.cmo: array.cmi hashtbl.cmi list.cmi map.cmi obj.cmi random.cmi \
-    sort.cmi sys.cmi camlinternalOO.cmi 
-camlinternalOO.cmx: array.cmx hashtbl.cmx list.cmx map.cmx obj.cmx random.cmx \
-    sort.cmx sys.cmx camlinternalOO.cmi 
+camlinternalOO.cmo: array.cmi char.cmi list.cmi map.cmi obj.cmi string.cmi \
+    sys.cmi camlinternalOO.cmi 
+camlinternalOO.cmx: array.cmx char.cmx list.cmx map.cmx obj.cmx string.cmx \
+    sys.cmx camlinternalOO.cmi 
 char.cmo: char.cmi 
 char.cmx: char.cmi 
 complex.cmo: complex.cmi 
@@ -66,8 +67,8 @@ parsing.cmo: array.cmi lexing.cmi obj.cmi parsing.cmi
 parsing.cmx: array.cmx lexing.cmx obj.cmx parsing.cmi 
 pervasives.cmo: pervasives.cmi 
 pervasives.cmx: pervasives.cmi 
-printexc.cmo: obj.cmi printf.cmi sys.cmi printexc.cmi 
-printexc.cmx: obj.cmx printf.cmx sys.cmx printexc.cmi 
+printexc.cmo: obj.cmi printf.cmi printexc.cmi 
+printexc.cmx: obj.cmx printf.cmx printexc.cmi 
 printf.cmo: buffer.cmi char.cmi list.cmi obj.cmi string.cmi printf.cmi 
 printf.cmx: buffer.cmx char.cmx list.cmx obj.cmx string.cmx printf.cmi 
 queue.cmo: obj.cmi queue.cmi 
@@ -76,10 +77,10 @@ random.cmo: array.cmi char.cmi digest.cmi int32.cmi int64.cmi nativeint.cmi \
     pervasives.cmi string.cmi random.cmi 
 random.cmx: array.cmx char.cmx digest.cmx int32.cmx int64.cmx nativeint.cmx \
     pervasives.cmx string.cmx random.cmi 
-scanf.cmo: array.cmi buffer.cmi list.cmi obj.cmi printf.cmi string.cmi \
-    sys.cmi scanf.cmi 
-scanf.cmx: array.cmx buffer.cmx list.cmx obj.cmx printf.cmx string.cmx \
-    sys.cmx scanf.cmi 
+scanf.cmo: buffer.cmi hashtbl.cmi list.cmi obj.cmi printf.cmi string.cmi \
+    scanf.cmi 
+scanf.cmx: buffer.cmx hashtbl.cmx list.cmx obj.cmx printf.cmx string.cmx \
+    scanf.cmi 
 set.cmo: set.cmi 
 set.cmx: set.cmi 
 sort.cmo: array.cmi sort.cmi 
diff --git a/stdlib/Compflags b/stdlib/Compflags
new file mode 100755
index 00000000..1a5d0f03
--- /dev/null
+++ b/stdlib/Compflags
@@ -0,0 +1,26 @@
+#!/bin/sh
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2004 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All 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: Compflags,v 1.1.4.1 2004/07/08 07:43:13 xleroy Exp $
+
+case $1 in
+  pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';;
+  camlinternalOO.cmi) echo ' -nopervasives';;
+  camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
+  arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';;
+  listLabels.cm[ox]|listLabels.p.cmx) echo ' -nolabels';;
+  stringLabels.cm[ox]|stringLabels.p.cmx) echo ' -nolabels';;
+  moreLabels.cm[ox]|moreLabels.p.cmx) echo ' -nolabels';;
+  *) echo ' ';;
+esac
diff --git a/stdlib/Makefile b/stdlib/Makefile
index 89b50e77..39d64fad 100644
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -11,7 +11,7 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile,v 1.75 2003/06/12 16:49:31 doligez Exp $
+# $Id: Makefile,v 1.81 2004/06/14 12:23:21 xleroy Exp $
 
 include ../config/Makefile
 
@@ -24,20 +24,18 @@ CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
 OPTCOMPFLAGS=-warn-error A -nostdlib
 CAMLDEP=../boot/ocamlrun ../tools/ocamldep
 
-BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
+OBJS=pervasives.cmo $(OTHERS)
+OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \
   hashtbl.cmo sort.cmo marshal.cmo obj.cmo \
   int32.cmo int64.cmo nativeint.cmo \
   lexing.cmo parsing.cmo \
   set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \
   printf.cmo format.cmo scanf.cmo \
   arg.cmo printexc.cmo gc.cmo \
-  digest.cmo random.cmo camlinternalOO.cmo oo.cmo \
-  genlex.cmo callback.cmo weak.cmo \
-  lazy.cmo filename.cmo complex.cmo
-LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
-
-OBJS=$(BASIC) labelled.cmo stdLabels.cmo
-ALLOBJS=$(BASIC) $(LABELLED:.ml=.cmo) stdLabels.cmo
+  digest.cmo random.cmo callback.cmo camlinternalOO.cmo oo.cmo \
+  genlex.cmo weak.cmo \
+  lazy.cmo filename.cmo complex.cmo \
+  arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo
 
 all: stdlib.cma std_exit.cmo camlheader camlheader_ur
 
@@ -46,6 +44,7 @@ allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILING)
 allopt-noprof:
 
 allopt-prof: stdlib.p.cmxa std_exit.p.cmx
+	rm -f std_exit.p.cmi
 
 install:
 	cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur \
@@ -69,13 +68,13 @@ installopt-prof:
 	cd $(LIBDIR); $(RANLIB) stdlib.p.a
 
 stdlib.cma: $(OBJS)
-	$(CAMLC) -a -o stdlib.cma $(ALLOBJS)
+	$(CAMLC) -a -o stdlib.cma $(OBJS)
 
 stdlib.cmxa: $(OBJS:.cmo=.cmx)
-	$(CAMLOPT) -a -o stdlib.cmxa $(ALLOBJS:.cmo=.cmx)
+	$(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx)
 
 stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx)
-	$(CAMLOPT) -a -o stdlib.p.cmxa $(ALLOBJS:.cmo=.p.cmx)
+	$(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx)
 
 camlheader camlheader_ur: header.c ../config/Makefile
 	if $(SHARPBANGSCRIPTS); then \
@@ -93,69 +92,33 @@ camlheader camlheader_ur: header.c ../config/Makefile
 clean::
 	rm -f camlheader camlheader_ur
 
-pervasives.cmi: pervasives.mli
-	$(CAMLC) $(COMPFLAGS) -nopervasives -c pervasives.mli
-
-pervasives.cmo: pervasives.ml
-	$(CAMLC) $(COMPFLAGS) -nopervasives -c pervasives.ml
-
-pervasives.cmx: pervasives.ml
-	$(CAMLOPT) $(OPTCOMPFLAGS) -nopervasives -c pervasives.ml
-
-pervasives.p.cmx: pervasives.ml
-	@if test -f pervasives.cmx; \
-           then mv pervasives.cmx pervasives.n.cmx; else :; fi
-	@if test -f pervasives.o; \
-           then mv pervasives.o pervasives.n.o; else :; fi
-	$(CAMLOPT) $(OPTCOMPFLAGS) -p -nopervasives -c pervasives.ml
-	mv pervasives.cmx pervasives.p.cmx
-	mv pervasives.o pervasives.p.o
-	@if test -f pervasives.n.cmx; \
-           then mv pervasives.n.cmx pervasives.cmx; else :; fi
-	@if test -f pervasives.n.o; \
-           then mv pervasives.n.o pervasives.o; else :; fi
-
-# camlinternalOO.cmi must be compiled with -nopervasives for applets
-camlinternalOO.cmi: camlinternalOO.mli
-	$(CAMLC) $(COMPFLAGS) -nopervasives -c camlinternalOO.mli
-
-# labelled modules require the -nolabels flag
-labelled.cmo:
-	$(MAKE) EXTRAFLAGS=-nolabels RUNTIME=$(RUNTIME) \
-                COMPILER=$(COMPILER) $(LABELLED:.ml=.cmo)
-	touch $@
-labelled.cmx:
-	$(MAKE) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.cmx)
-	touch $@
-labelled.p.cmx:
-	$(MAKE) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.p.cmx)
-	touch $@
-
 .SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
 
 .mli.cmi:
-	$(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+	$(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $<
 
 .ml.cmo:
-	$(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+	$(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $<
 
 .ml.cmx:
-	$(CAMLOPT) $(OPTCOMPFLAGS) $(EXTRAFLAGS) -c $<
+	$(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $<
 
 .ml.p.cmx:
-	@if test -f $*.cmx; then mv $*.cmx $*.n.cmx; else :; fi
-	@if test -f $*.o; then mv $*.o $*.n.o; else :; fi
-	$(CAMLOPT) $(OPTCOMPFLAGS) $(EXTRAFLAGS) -p -c $<
-	mv $*.cmx $*.p.cmx
-	mv $*.o $*.p.o
-	@if test -f $*.n.cmx; then mv $*.n.cmx $*.cmx; else :; fi
-	@if test -f $*.n.o; then mv $*.n.o $*.o; else :; fi
-
-$(ALLOBJS) labelled.cmo std_exit.cmo: pervasives.cmi $(COMPILER)
-$(ALLOBJS:.cmo=.cmx) labelled.cmx std_exit.cmx: pervasives.cmi $(OPTCOMPILER)
-$(ALLOBJS:.cmo=.p.cmx) labelled.p.cmx std_exit.p.cmx: pervasives.cmi $(OPTCOMPILER)
-$(ALLOBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
-labelled.cmo labelled.cmx labelled.p.cmx: $(LABELLED) $(LABELLED:.ml=.mli)
+	$(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -p -c -o $*.p.cmx $<
+
+# Dependencies on the compiler
+$(OBJS) std_exit.cmo: $(COMPILER)
+$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
+$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER)
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER)
+
+# Dependencies on Pervasives (not tracked by ocamldep)
+$(OBJS) std_exit.cmo: pervasives.cmi
+$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi
+$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi
+$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx
+$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx
 
 clean::
 	rm -f *.cm* *.o *.a
diff --git a/stdlib/Makefile.Mac b/stdlib/Makefile.Mac
deleted file mode 100644
index a67d1ca1..00000000
--- a/stdlib/Makefile.Mac
+++ /dev/null
@@ -1,74 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#            Damien Doligez, projet Para, INRIA Rocquencourt            #
-#                                                                       #
-#   Copyright 1999 Institut National de Recherche en Informatique et    #
-#   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the GNU Library General Public License, with     #
-#   the special exception on linking described in file ../LICENSE.      #
-#                                                                       #
-#########################################################################
-
-# $Id: Makefile.Mac,v 1.21 2002/04/24 09:49:06 xleroy Exp $
-
-RUNTIME = ::boot:ocamlrun
-COMPILER = ::ocamlc
-CAMLC = {RUNTIME} {COMPILER}
-CAMLDEP = ::boot:ocamlrun ::tools:ocamldep
-
-OBJS = pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo ¶
-  hashtbl.cmo sort.cmo marshal.cmo obj.cmo ¶
-  lexing.cmo parsing.cmo ¶
-  set.cmo map.cmo stack.cmo queue.cmo stream.cmo ¶
-  buffer.cmo printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo ¶
-  digest.cmo random.cmo oo.cmo camlInternal.cmo ¶
-  genlex.cmo callback.cmo weak.cmo ¶
-  lazy.cmo filename.cmo int32.cmo int64.cmo nativeint.cmo complex.cmo
-
-all Ä stdlib.cma std_exit.cmo camlheader camlheader_ur
-
-install Ä
-    duplicate -y stdlib.cma std_exit.cmo Å.cmi Å.mli camlheader camlheader_ur ¶
-              "{LIBDIR}"
-
-stdlib.cma Ä {OBJS}
-    {CAMLC} -a -o stdlib.cma {OBJS}
-
-camlheader Ä
-    begin
-      quote -n "ocamlrun"; echo ' "{command}" {"Parameters"}'
-      echo 'exit {status}'
-      echo
-    end > camlheader
-
-camlheader_ur Ä
-    echo -n ' ' > camlheader_ur
-
-clean ÄÄ
-    delete -i camlheader camlheader_ur
-
-pervasives.cmi Ä pervasives.mli
-    {CAMLC} {COMPFLAGS} -nopervasives -c pervasives.mli
-
-pervasives.cmo Ä pervasives.ml
-    {CAMLC} {COMPFLAGS} -nopervasives -c pervasives.ml
-
-# camlinternalOO.cmi must be compiled with -nopervasives for applets
-camlinternalOO.cmi Ä camlinternalOO.mli
-    {CAMLC} {COMPFLAGS} -nopervasives -c camlinternalOO.mli
-
-.cmi Ä .mli
-    {CAMLC} {COMPFLAGS} -c {default}.mli
-
-.cmo Ä .ml
-    {CAMLC} {COMPFLAGS} -c {default}.ml
-
-{OBJS} std_exit.cmo Ä pervasives.cmi
-
-clean ÄÄ
-    delete -i Å.cm[aio] || set status 0
-
-depend Ä
-    {CAMLDEP} Å.mli Å.ml > Makefile.Mac.depend
diff --git a/stdlib/Makefile.Mac.depend b/stdlib/Makefile.Mac.depend
deleted file mode 100644
index 0c7f549d..00000000
--- a/stdlib/Makefile.Mac.depend
+++ /dev/null
@@ -1,74 +0,0 @@
-format.cmiÄ buffer.cmi 
-genlex.cmiÄ stream.cmi 
-parsing.cmiÄ lexing.cmi obj.cmi 
-printf.cmiÄ buffer.cmi 
-arg.cmoÄ array.cmi list.cmi printf.cmi string.cmi sys.cmi arg.cmi 
-arg.cmxÄ array.cmx list.cmx printf.cmx string.cmx sys.cmx arg.cmi 
-array.cmoÄ array.cmi 
-array.cmxÄ array.cmi 
-buffer.cmoÄ string.cmi sys.cmi buffer.cmi 
-buffer.cmxÄ string.cmx sys.cmx buffer.cmi 
-callback.cmoÄ obj.cmi callback.cmi 
-callback.cmxÄ obj.cmx callback.cmi 
-char.cmoÄ char.cmi 
-char.cmxÄ char.cmi 
-digest.cmoÄ string.cmi digest.cmi 
-digest.cmxÄ string.cmx digest.cmi 
-filename.cmoÄ buffer.cmi string.cmi sys.cmi filename.cmi 
-filename.cmxÄ buffer.cmx string.cmx sys.cmx filename.cmi 
-format.cmoÄ buffer.cmi obj.cmi string.cmi format.cmi 
-format.cmxÄ buffer.cmx obj.cmx string.cmx format.cmi 
-gc.cmoÄ printf.cmi sys.cmi gc.cmi 
-gc.cmxÄ printf.cmx sys.cmx gc.cmi 
-genlex.cmoÄ char.cmi hashtbl.cmi list.cmi stream.cmi string.cmi genlex.cmi 
-genlex.cmxÄ char.cmx hashtbl.cmx list.cmx stream.cmx string.cmx genlex.cmi 
-hashtbl.cmoÄ array.cmi sys.cmi hashtbl.cmi 
-hashtbl.cmxÄ array.cmx sys.cmx hashtbl.cmi 
-int32.cmoÄ int32.cmi 
-int32.cmxÄ int32.cmi 
-int64.cmoÄ int32.cmi obj.cmi int64.cmi 
-int64.cmxÄ int32.cmx obj.cmx int64.cmi 
-lazy.cmoÄ lazy.cmi 
-lazy.cmxÄ lazy.cmi 
-lexing.cmoÄ string.cmi lexing.cmi 
-lexing.cmxÄ string.cmx lexing.cmi 
-list.cmoÄ array.cmi list.cmi 
-list.cmxÄ array.cmx list.cmi 
-map.cmoÄ map.cmi 
-map.cmxÄ map.cmi 
-marshal.cmoÄ string.cmi marshal.cmi 
-marshal.cmxÄ string.cmx marshal.cmi 
-nativeint.cmoÄ sys.cmi nativeint.cmi 
-nativeint.cmxÄ sys.cmx nativeint.cmi 
-obj.cmoÄ marshal.cmi obj.cmi 
-obj.cmxÄ marshal.cmx obj.cmi 
-oo.cmoÄ array.cmi hashtbl.cmi list.cmi map.cmi obj.cmi random.cmi sort.cmi ¶
-    sys.cmi oo.cmi 
-oo.cmxÄ array.cmx hashtbl.cmx list.cmx map.cmx obj.cmx random.cmx sort.cmx ¶
-    sys.cmx oo.cmi 
-parsing.cmoÄ array.cmi lexing.cmi obj.cmi parsing.cmi 
-parsing.cmxÄ array.cmx lexing.cmx obj.cmx parsing.cmi 
-pervasives.cmoÄ pervasives.cmi 
-pervasives.cmxÄ pervasives.cmi 
-printexc.cmoÄ obj.cmi printf.cmi string.cmi sys.cmi printexc.cmi 
-printexc.cmxÄ obj.cmx printf.cmx string.cmx sys.cmx printexc.cmi 
-printf.cmoÄ buffer.cmi obj.cmi string.cmi printf.cmi 
-printf.cmxÄ buffer.cmx obj.cmx string.cmx printf.cmi 
-queue.cmoÄ queue.cmi 
-queue.cmxÄ queue.cmi 
-random.cmoÄ array.cmi char.cmi digest.cmi string.cmi random.cmi 
-random.cmxÄ array.cmx char.cmx digest.cmx string.cmx random.cmi 
-set.cmoÄ set.cmi 
-set.cmxÄ set.cmi 
-sort.cmoÄ array.cmi sort.cmi 
-sort.cmxÄ array.cmx sort.cmi 
-stack.cmoÄ list.cmi stack.cmi 
-stack.cmxÄ list.cmx stack.cmi 
-stream.cmoÄ list.cmi obj.cmi string.cmi stream.cmi 
-stream.cmxÄ list.cmx obj.cmx string.cmx stream.cmi 
-string.cmoÄ char.cmi list.cmi string.cmi 
-string.cmxÄ char.cmx list.cmx string.cmi 
-sys.cmoÄ sys.cmi 
-sys.cmxÄ sys.cmi 
-weak.cmoÄ obj.cmi weak.cmi 
-weak.cmxÄ obj.cmx weak.cmi 
diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt
index e9d58820..8e4e80a9 100644
--- a/stdlib/Makefile.nt
+++ b/stdlib/Makefile.nt
@@ -11,31 +11,31 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt,v 1.33 2003/06/24 08:21:39 xleroy Exp $
+# $Id: Makefile.nt,v 1.35 2004/06/14 12:23:40 xleroy Exp $
 
 include ../config/Makefile
 
 RUNTIME=../boot/ocamlrun
 COMPILER=../ocamlc
 CAMLC=$(RUNTIME) $(COMPILER)
+COMPFLAGS=-warn-error A -nostdlib
 OPTCOMPILER=../ocamlopt
 CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
+OPTCOMPFLAGS=-warn-error A -nostdlib
 CAMLDEP=../boot/ocamlrun ../tools/ocamldep
 
-BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
+OBJS=pervasives.cmo $(OTHERS)
+OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \
   hashtbl.cmo sort.cmo marshal.cmo obj.cmo \
   int32.cmo int64.cmo nativeint.cmo \
   lexing.cmo parsing.cmo \
   set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \
   printf.cmo format.cmo scanf.cmo \
   arg.cmo printexc.cmo gc.cmo \
-  digest.cmo random.cmo camlinternalOO.cmo oo.cmo \
-  genlex.cmo callback.cmo weak.cmo \
-  lazy.cmo filename.cmo complex.cmo
-LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
-
-OBJS=$(BASIC) labelled.cmo stdLabels.cmo
-ALLOBJS=$(BASIC) $(LABELLED:.ml=.cmo) stdLabels.cmo
+  digest.cmo random.cmo callback.cmo camlinternalOO.cmo oo.cmo \
+  genlex.cmo weak.cmo \
+  lazy.cmo filename.cmo complex.cmo \
+  arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo
 
 all: stdlib.cma std_exit.cmo camlheader camlheader_ur
 
@@ -48,10 +48,10 @@ installopt:
 	cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(LIBDIR)
 
 stdlib.cma: $(OBJS)
-	$(CAMLC) -a -o stdlib.cma $(ALLOBJS)
+	$(CAMLC) -a -o stdlib.cma $(OBJS)
 
 stdlib.cmxa: $(OBJS:.cmo=.cmx)
-	$(CAMLOPT) -a -o stdlib.cmxa $(ALLOBJS:.cmo=.cmx)
+	$(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx)
 
 camlheader camlheader_ur: headernt.c ../config/Makefile
 	$(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -o camlheader.exe headernt.c
@@ -61,46 +61,30 @@ camlheader camlheader_ur: headernt.c ../config/Makefile
 clean::
 	rm -f camlheader camlheader_ur
 
-pervasives.cmi: pervasives.mli
-	$(CAMLC) $(COMPFLAGS) -nopervasives -c pervasives.mli
-
-pervasives.cmo: pervasives.ml
-	$(CAMLC) $(COMPFLAGS) -nopervasives -c pervasives.ml
-
-pervasives.cmx: pervasives.ml
-	$(CAMLOPT) $(COMPFLAGS) -nopervasives -c pervasives.ml
-
-# camlinternalOO.cmi must be compiled with -nopervasives for applets
-camlinternalOO.cmi: camlinternalOO.mli
-	$(CAMLC) $(COMPFLAGS) -nopervasives -c camlinternalOO.mli
-
-# labelled modules require the -nolabels flag
-labelled.cmo:
-	$(MAKEREC) EXTRAFLAGS=-nolabels RUNTIME=$(RUNTIME) COMPILER=$(COMPILER) $(LABELLED:.ml=.cmo)
-	touch $@
-labelled.cmx:
-	$(MAKEREC) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.cmx)
-	touch $@
-labelled.p.cmx:
-	$(MAKEREC) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.p.cmx)
-	touch $@
-
-# generic rules
 .SUFFIXES: .mli .ml .cmi .cmo .cmx
 
 .mli.cmi:
-	$(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+	$(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $<
 
 .ml.cmo:
-	$(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+	$(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $<
 
 .ml.cmx:
-	$(CAMLOPT) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
-
-$(ALLOBJS) labelled.cmo std_exit.cmo: pervasives.cmi $(COMPILER)
-$(ALLOBJS:.cmo=.cmx) labelled.cmx std_exit.cmx: pervasives.cmi $(OPTCOMPILER)
-$(ALLOBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
-labelled.cmo labelled.cmx: $(LABELLED) $(LABELLED:.ml=.mli)
+	$(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $<
+
+# Dependencies on the compiler
+$(OBJS) std_exit.cmo: $(COMPILER)
+$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
+$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER)
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER)
+
+# Dependencies on Pervasives (not tracked by ocamldep)
+$(OBJS) std_exit.cmo: pervasives.cmi
+$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi
+$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi
+$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx
+$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx
 
 clean::
 	rm -f *.cm* *.$(O) *.$(A)
diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules
index 2ed30b75..3242602f 100644
--- a/stdlib/StdlibModules
+++ b/stdlib/StdlibModules
@@ -1,5 +1,6 @@
-# This file lists all standard library modules.
+# This file lists all standard library modules. -*- Makefile -*-
 # It is used in particular to know what to expunge in toplevels.
+# $Id: StdlibModules,v 1.2 2003/11/26 10:57:14 starynke Exp $
 
 STDLIB_MODULES=\
   arg \
diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index 6f5e7fdc..9b709652 100644
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arg.ml,v 1.30 2003/07/24 18:23:54 doligez Exp $ *)
+(* $Id: arg.ml,v 1.33.2.1 2004/07/02 09:01:16 doligez Exp $ *)
 
 type key = string
 type doc = string
@@ -46,6 +46,8 @@ type error =
   | Missing of string
   | Message of string
 
+exception Stop of error;; (* used internally *)
+
 open Printf
 
 let rec assoc3 x l =
@@ -68,13 +70,24 @@ let print_spec buf (key, spec, doc) =
   | _ -> bprintf buf "  %s %s\n" key doc
 ;;
 
+let help_action () = raise (Stop (Unknown "-help"));;
+
+let add_help speclist =
+  let add1 =
+    try ignore (assoc3 "-help" speclist); []
+    with Not_found ->
+            ["-help", Unit help_action, " Display this list of options"]
+  and add2 =
+    try ignore (assoc3 "--help" speclist); []
+    with Not_found ->
+            ["--help", Unit help_action, " Display this list of options"]
+  in
+  speclist @ (add1 @ add2)
+;;
+
 let usage_b buf speclist errmsg =
   bprintf buf "%s\n" errmsg;
-  List.iter (print_spec buf) speclist;
-  try ignore (assoc3 "-help" speclist)
-  with Not_found -> bprintf buf "  -help   Display this list of options\n";
-  try ignore (assoc3 "--help" speclist)
-  with Not_found -> bprintf buf "  --help  Display this list of options\n";
+  List.iter (print_spec buf) (add_help speclist);
 ;;
 
 let usage speclist errmsg =
@@ -120,11 +133,11 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg =
       begin try
         let rec treat_action = function
         | Unit f -> f ();
-        | Bool f ->
+        | Bool f when !current + 1 < l ->
             let arg = argv.(!current + 1) in
             begin try f (bool_of_string arg)
             with Invalid_argument "bool_of_string" ->
-                   stop (Wrong (s, arg, "a boolean"))
+                   raise (Stop (Wrong (s, arg, "a boolean")))
             end;
             incr current;
         | Set r -> r := true;
@@ -138,7 +151,8 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg =
               f argv.(!current + 1);
               incr current;
             end else begin
-              stop (Wrong (s, arg, "one of: " ^ (make_symlist "" " " "" symb)))
+              raise (Stop (Wrong (s, arg, "one of: "
+                                          ^ (make_symlist "" " " "" symb))))
             end
         | Set_string r when !current + 1 < l ->
             r := argv.(!current + 1);
@@ -146,25 +160,29 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg =
         | Int f when !current + 1 < l ->
             let arg = argv.(!current + 1) in
             begin try f (int_of_string arg)
-            with Failure "int_of_string" -> stop (Wrong (s, arg, "an integer"))
+            with Failure "int_of_string" ->
+                   raise (Stop (Wrong (s, arg, "an integer")))
             end;
             incr current;
         | Set_int r when !current + 1 < l ->
             let arg = argv.(!current + 1) in
             begin try r := (int_of_string arg)
-            with Failure "int_of_string" -> stop (Wrong (s, arg, "an integer"))
+            with Failure "int_of_string" ->
+                   raise (Stop (Wrong (s, arg, "an integer")))
             end;
             incr current;
         | Float f when !current + 1 < l ->
             let arg = argv.(!current + 1) in
             begin try f (float_of_string arg);
-            with Failure "float_of_string" -> stop (Wrong (s, arg, "a float"))
+            with Failure "float_of_string" ->
+                   raise (Stop (Wrong (s, arg, "a float")))
             end;
             incr current;
         | Set_float r when !current + 1 < l ->
             let arg = argv.(!current + 1) in
             begin try r := (float_of_string arg);
-            with Failure "float_of_string" -> stop (Wrong (s, arg, "a float"))
+            with Failure "float_of_string" ->
+                   raise (Stop (Wrong (s, arg, "a float")))
             end;
             incr current;
         | Tuple specs ->
@@ -174,9 +192,11 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg =
               f argv.(!current + 1);
               incr current;
             done;
-        | _ -> stop (Missing s) in
+        | _ -> raise (Stop (Missing s))
+        in
         treat_action action
       with Bad m -> stop (Message m);
+         | Stop e -> stop e;
       end;
       incr current;
     end else begin
@@ -190,6 +210,38 @@ let parse l f msg =
   try
     parse_argv Sys.argv l f msg;
   with
-  | Bad msg -> eprintf "%s" msg; exit 0;
-  | Help msg -> eprintf "%s" msg; exit 2;
+  | Bad msg -> eprintf "%s" msg; exit 2;
+  | Help msg -> printf "%s" msg; exit 0;
+;;
+
+let rec second_word s =
+  let len = String.length s in
+  let rec loop n =
+    if n >= len then len
+    else if s.[n] = ' ' then loop (n+1)
+    else n
+  in
+  try loop (String.index s ' ')
+  with Not_found -> len
+;;
+
+let max_arg_len cur (kwd, _, doc) =
+  max cur (String.length kwd + second_word doc)
+;;
+
+let add_padding len ksd =
+  match ksd with
+  | (_, Symbol _, _) -> ksd
+  | (kwd, spec, msg) ->
+      let cutcol = second_word msg in
+      let spaces = String.make (len - String.length kwd - cutcol) ' ' in
+      let prefix = String.sub msg 0 cutcol in
+      let suffix = String.sub msg cutcol (String.length msg - cutcol) in
+      (kwd, spec, prefix ^ spaces ^ suffix)
+;;
+
+let align speclist =
+  let completed = add_help speclist in
+  let len = List.fold_left max_arg_len 0 completed in
+  List.map (add_padding len) completed
 ;;
diff --git a/stdlib/arg.mli b/stdlib/arg.mli
index e4fb4718..aea24592 100644
--- a/stdlib/arg.mli
+++ b/stdlib/arg.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arg.mli,v 1.33 2003/07/24 18:23:54 doligez Exp $ *)
+(* $Id: arg.mli,v 1.35 2004/06/11 23:45:46 doligez Exp $ *)
 
 (** Parsing of command line arguments.
 
@@ -58,7 +58,6 @@ type spec =
                                    call the function with the symbol *)
   | Rest of (string -> unit)   (** Stop interpreting keywords and call the 
                                    function with each remaining argument *)
-
 (** The concrete type describing the behavior associated
    with a keyword. *)
 
@@ -121,6 +120,13 @@ val usage : (key * spec * doc) list -> usage_msg -> unit
     {!Arg.parse} prints in case of error.
     [speclist] and [usage_msg] are the same as for [Arg.parse]. *)
 
+val align: (key * spec * doc) list -> (key * spec * doc) list;;
+(** Align the documentation strings by inserting spaces at the first
+    space, according to the length of the keyword.  Use a
+    space as the first character in a doc string if you want to
+    align the whole string.  The doc strings corresponding to
+    [Symbol] arguments are not aligned. *)
+
 val current : int ref
 (** Position (in {!Sys.argv}) of the argument being processed.  You can
     change this value, e.g. to force {!Arg.parse} to skip some arguments.
diff --git a/stdlib/array.ml b/stdlib/array.ml
index e42e7927..1307dcc8 100644
--- a/stdlib/array.ml
+++ b/stdlib/array.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: array.ml,v 1.22 2003/01/21 12:57:33 doligez Exp $ *)
+(* $Id: array.ml,v 1.23 2003/12/31 14:20:39 doligez Exp $ *)
 
 (* Array operations *)
 
@@ -20,8 +20,8 @@ external get: 'a array -> int -> 'a = "%array_safe_get"
 external set: 'a array -> int -> 'a -> unit = "%array_safe_set"
 external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
 external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
-external make: int -> 'a -> 'a array = "make_vect"
-external create: int -> 'a -> 'a array = "make_vect"
+external make: int -> 'a -> 'a array = "caml_make_vect"
+external create: int -> 'a -> 'a array = "caml_make_vect"
 
 let init l f =
   if l = 0 then [||] else
diff --git a/stdlib/array.mli b/stdlib/array.mli
index e8d5e7a2..2989c67c 100644
--- a/stdlib/array.mli
+++ b/stdlib/array.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: array.mli,v 1.36 2002/06/05 12:12:46 doligez Exp $ *)
+(* $Id: array.mli,v 1.38 2003/12/31 14:20:39 doligez Exp $ *)
 
 (** Array operations. *)
 
@@ -22,20 +22,20 @@ external get : 'a array -> int -> 'a = "%array_safe_get"
 (** [Array.get a n] returns the element number [n] of array [a].
    The first element has number 0.
    The last element has number [Array.length a - 1].
+   You can also write [a.(n)] instead of [Array.get a n]. 
 
-   Raise [Invalid_argument "Array.get"]  if [n] is outside the range
-   0 to [(Array.length a - 1)].
-   You can also write [a.(n)] instead of [Array.get a n]. *)
+   Raise [Invalid_argument "index out of bounds"]
+   if [n] is outside the range 0 to [(Array.length a - 1)]. *)
 
 external set : 'a array -> int -> 'a -> unit = "%array_safe_set"
 (** [Array.set a n x] modifies array [a] in place, replacing
    element number [n] with [x].
+   You can also write [a.(n) <- x] instead of [Array.set a n x].
 
-   Raise [Invalid_argument "Array.set"] if [n] is outside the range
-   0 to [Array.length a - 1].
-   You can also write [a.(n) <- x] instead of [Array.set a n x]. *)
+   Raise [Invalid_argument "index out of bounds"]
+   if [n] is outside the range 0 to [Array.length a - 1]. *)
         
-external make : int -> 'a -> 'a array = "make_vect"
+external make : int -> 'a -> 'a array = "caml_make_vect"
 (** [Array.make n x] returns a fresh array of length [n],
    initialized with [x].
    All the elements of this new array are initially
@@ -48,7 +48,7 @@ external make : int -> 'a -> 'a array = "make_vect"
    If the value of [x] is a floating-point number, then the maximum
    size is only [Sys.max_array_length / 2].*)
 
-external create : int -> 'a -> 'a array = "make_vect"
+external create : int -> 'a -> 'a array = "caml_make_vect"
 (** @deprecated [Array.create] is an alias for {!Array.make}. *)
 
 val init : int -> (int -> 'a) -> 'a array
diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli
index 267d2b4d..29825a54 100644
--- a/stdlib/arrayLabels.mli
+++ b/stdlib/arrayLabels.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arrayLabels.mli,v 1.9 2002/06/05 12:12:46 doligez Exp $ *)
+(* $Id: arrayLabels.mli,v 1.10 2003/12/31 14:20:39 doligez Exp $ *)
 
 (** Array operations. *)
 
@@ -34,7 +34,7 @@ external set : 'a array -> int -> 'a -> unit = "%array_safe_set"
    0 to [Array.length a - 1].
    You can also write [a.(n) <- x] instead of [Array.set a n x]. *)
 
-external make : int -> 'a -> 'a array = "make_vect"
+external make : int -> 'a -> 'a array = "caml_make_vect"
 (** [Array.make n x] returns a fresh array of length [n],
    initialized with [x].
    All the elements of this new array are initially
@@ -47,7 +47,7 @@ external make : int -> 'a -> 'a array = "make_vect"
    If the value of [x] is a floating-point number, then the maximum
    size is only [Sys.max_array_length / 2].*)
 
-external create : int -> 'a -> 'a array = "make_vect"
+external create : int -> 'a -> 'a array = "caml_make_vect"
 (** @deprecated [Array.create] is an alias for {!ArrayLabels.make}. *)
 
 val init : int -> f:(int -> 'a) -> 'a array
diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
index dcde111e..8cfc3fc3 100644
--- a/stdlib/buffer.ml
+++ b/stdlib/buffer.ml
@@ -11,6 +11,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: buffer.ml,v 1.17 2004/06/14 20:20:16 weis Exp $ *)
+
 (* Extensible buffers *)
 
 type t =
@@ -27,6 +29,22 @@ let create n =
 
 let contents b = String.sub b.buffer 0 b.position
 
+let sub b ofs len =
+  if ofs < 0 || len < 0 || ofs > b.position - len 
+  then invalid_arg "Buffer.sub"
+  else begin
+    let r = String.create len in
+    String.blit b.buffer ofs r 0 len;
+    r
+  end
+;;
+
+let nth b ofs = 
+  if ofs < 0 || ofs >= b.position then 
+   invalid_arg "Buffer.nth"
+  else String.get b.buffer ofs
+;;
+
 let length b = b.position
 
 let clear b = b.position <- 0
@@ -87,9 +105,9 @@ let closing = function
   | _ -> assert false;;
 
 (* opening and closing: open and close characters, typically ( and )
-   k balance of opening and closing chars
-   s the string where we are searching
-   start the index where we start the search *)
+   k: balance of opening and closing chars
+   s: the string where we are searching
+   start: the index where we start the search. *)
 let advance_to_closing opening closing k s start =
   let rec advance k i lim =
     if i >= lim then raise Not_found else
@@ -110,7 +128,7 @@ let advance_to_non_alpha s start =
     | _ -> i in
   advance start (String.length s);;
 
-(* We are just at the beginning of an ident in s, starting at start *)
+(* We are just at the beginning of an ident in s, starting at start. *)
 let find_ident s start =
   match s.[start] with
   (* Parenthesized ident ? *)
diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli
index 73e02e29..ec8bbcfd 100644
--- a/stdlib/buffer.mli
+++ b/stdlib/buffer.mli
@@ -11,6 +11,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
+(* $Id: buffer.mli,v 1.20 2004/04/17 13:36:03 guesdon Exp $ *)
+
 (** Extensible string buffers.
 
    This module implements string buffers that automatically expand
@@ -40,6 +42,16 @@ val contents : t -> string
 (** Return a copy of the current contents of the buffer.
    The buffer itself is unchanged. *)
 
+val sub : t -> int -> int -> string
+(** [Buffer.sub b off len] returns (a copy of) the substring of the
+current contents of the buffer [b] starting at offset [off] of length
+[len] bytes. May raise [Invalid_argument] if out of bounds request. The
+buffer itself is unaffected. *)
+
+val nth : t -> int -> char
+(** get the n-th character of the buffer. Raise [Invalid_argument] if
+index out of bounds *)
+
 val length : t -> int
 (** Return the number of characters currently contained in the buffer. *)
 
diff --git a/stdlib/callback.ml b/stdlib/callback.ml
index cc1ac874..9a3c5db7 100644
--- a/stdlib/callback.ml
+++ b/stdlib/callback.ml
@@ -11,11 +11,12 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: callback.ml,v 1.4 2001/12/07 13:40:50 xleroy Exp $ *)
+(* $Id: callback.ml,v 1.5 2003/12/31 14:20:39 doligez Exp $ *)
 
 (* Registering Caml values with the C runtime for later callbacks *)
 
-external register_named_value: string -> Obj.t -> unit = "register_named_value"
+external register_named_value : string -> Obj.t -> unit
+                              = "caml_register_named_value"
 
 let register name v =
   register_named_value name (Obj.repr v)
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 57dfa5c7..b1040415 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: camlinternalOO.ml,v 1.4 2003/06/19 15:53:51 xleroy Exp $ *)
+(* $Id: camlinternalOO.ml,v 1.9 2004/05/26 11:10:51 garrigue Exp $ *)
 
 open Obj
 
@@ -54,185 +54,36 @@ let params = {
 (**** Parameters ****)
 
 let step = Sys.word_size / 16
-let first_bucket = 0
-let bucket_size = 32                    (* Must be 256 or less *)
 let initial_object_size = 2
 
-(**** Index ****)
-
-type label = int
-
-let label_count = ref 0
-
-let next label =
-  incr label_count;
-  let label = label + step in
-  if label mod (step * bucket_size) = 0 then
-    label + step * (65536 - bucket_size)
-  else
-    label
-
-let decode label =
-  (label / 65536 / step, (label mod (step * bucket_size)) / step)
-
 (**** Items ****)
 
-type item
+type item = DummyA | DummyB | DummyC of int
 
 let dummy_item = (magic () : item)
 
-(**** Buckets ****)
-
-type bucket = item array
-
-let version = ref 0
-
-let set_bucket_version (bucket : bucket) =
-  bucket.(bucket_size) <- (magic !version : item)
-
-let bucket_version bucket =
-  (magic bucket.(bucket_size) : int)
-
-let bucket_list = ref []
-
-let empty_bucket = [| |]
-
-let new_bucket () =
-  let bucket = Array.create (bucket_size + 1) dummy_item in
-  set_bucket_version bucket;
-  bucket_list := bucket :: !bucket_list;
-  bucket
-
-let copy_bucket bucket =
-  let bucket = Array.copy bucket in
-  set_bucket_version bucket;
-  bucket.(bucket_size) <- (magic !version : item);
-  bucket_list := bucket :: !bucket_list;
-  bucket
-
-(**** Make a clean bucket ****)
-
-let new_filled_bucket pos methods =
-  let bucket = new_bucket () in
-  List.iter
-    (fun (lab, met) ->
-       let (buck, elem) = decode lab in
-       if buck = pos then
-         bucket.(elem) <- (magic met : item))
-    (List.rev methods);
-  bucket
-
-(**** Bucket merging ****)
-
-let small_buckets = ref (Array.create 10 [| |])
-let small_bucket_count = ref 0
-
-let insert_bucket bucket =
-  let length = Array.length !small_buckets in
-  if !small_bucket_count >= length then begin
-    let new_array = Array.create (2 * length) [| |] in
-    Array.blit !small_buckets 0 new_array 0 length;
-    small_buckets := new_array
-  end;
-  !small_buckets.(!small_bucket_count) <- bucket;
-  incr small_bucket_count
-
-let remove_bucket n =
-  !small_buckets.(n) <- !small_buckets.(!small_bucket_count - 1);
-  decr small_bucket_count
-
-let bucket_used b =
-  let n = ref 0 in
-  for i = 0 to bucket_size - 1 do
-    if b.(i) != dummy_item then incr n
-  done;
-  !n
-
-let small_bucket b = bucket_used b <= params.bucket_small_size
-
-exception Failed
-
-let rec except e =
-  function
-    [] -> []
-  | e'::l -> if e == e' then l else e'::(except e l)
-
-let merge_buckets b1 b2 =
-  for i = 0 to bucket_size - 1 do
-    if
-      (b2.(i) != dummy_item) && (b1.(i) != dummy_item) && (b2.(i) != b1.(i))
-    then
-      raise Failed
-  done;
-  for i = 0 to bucket_size - 1 do
-    if b2.(i) != dummy_item then
-      b1.(i) <- b2.(i)
-  done;
-  bucket_list := except b2 !bucket_list;
-  b1
-
-let prng = Random.State.make [| 0 |];;
-
-let rec choose bucket i =
-  if (i > 0) && (!small_bucket_count > 0) then begin
-    let n = Random.State.int prng !small_bucket_count in
-    if not (small_bucket !small_buckets.(n)) then begin
-      remove_bucket n; choose bucket i
-    end else
-      try
-        merge_buckets !small_buckets.(n) bucket
-      with Failed ->
-        choose bucket (i - 1)
-  end else begin
-    insert_bucket bucket;
-    bucket
-  end
-
-let compact b =
-  if
-    (b != empty_bucket) && (bucket_version b = !version) && (small_bucket b)
-  then
-    choose b params.retry_count
-  else
-    b
+(**** Types ****)
 
-let compact_buckets buckets =
-  for i = first_bucket to Array.length buckets - 1 do
-    buckets.(i) <- compact buckets.(i)
-  done
+type tag
+type label = int
+type closure = item
+type t = DummyA | DummyB | DummyC of int
+type obj = t array
+external ret : (obj -> 'a) -> closure = "%identity"
 
 (**** Labels ****)
 
-let first_label = first_bucket * 65536 * step
-
-let last_label = ref first_label
-let methods = Hashtbl.create 101
-
-let new_label () =
-  let label = !last_label in
-  last_label := next !last_label;
-  label
-
-let new_method met =
-  try
-    Hashtbl.find methods met
-  with Not_found ->
-    let label = new_label () in
-    Hashtbl.add methods met label;
-    label
-
-let public_method_label met =
-  try
-    Hashtbl.find methods met
-  with Not_found ->
-    invalid_arg "Oo.public_method_label"
-
-let new_anonymous_method =
-  new_label
-
-(**** Types ****)
-
-type obj = t array
+let public_method_label s : tag =
+  let accu = ref 0 in
+  for i = 0 to String.length s - 1 do
+    accu := 223 * !accu + Char.code s.[i]
+  done;
+  (* reduce to 31 bits *)
+  accu := !accu land (1 lsl 31 - 1);
+  (* make it signed for 64 bits architectures *)
+  let tag = if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu in
+  (* Printf.eprintf "%s = %d\n" s tag; flush stderr; *)
+  magic tag
 
 (**** Sparse array ****)
 
@@ -247,7 +98,7 @@ type labs = bool Labs.t
 (* The compiler assumes that the first field of this structure is [size]. *)
 type table =
  { mutable size: int;
-   mutable buckets: bucket array;
+   mutable methods: closure array;
    mutable methods_by_name: meths;
    mutable methods_by_label: labs;
    mutable previous_states:
@@ -258,20 +109,31 @@ type table =
    mutable initializers: (obj -> unit) list }
 
 let dummy_table =
-  { buckets = [| |];
+  { methods = [| dummy_item |];
     methods_by_name = Meths.empty;
     methods_by_label = Labs.empty;
     previous_states = [];
     hidden_meths = [];
     vars = Vars.empty;
     initializers = [];
-    size = initial_object_size }
+    size = 0 }
 
 let table_count = ref 0
 
-let new_table () =
+let null_item : item = Obj.obj (Obj.field (Obj.repr 0n) 1)
+
+let rec fit_size n =
+  if n <= 2 then n else
+  fit_size ((n+1)/2) * 2
+
+let new_table pub_labels =
   incr table_count;
-  { buckets = [| |];
+  let len = Array.length pub_labels in
+  let methods = Array.create (len*2+2) null_item in
+  methods.(0) <- magic len;
+  methods.(1) <- magic (fit_size len * Sys.word_size / 8 - 1);
+  for i = 0 to len - 1 do methods.(i*2+3) <- magic pub_labels.(i) done;
+  { methods = methods;
     methods_by_name = Meths.empty;
     methods_by_label = Labs.empty;
     previous_states = [];
@@ -281,40 +143,42 @@ let new_table () =
     size = initial_object_size }
 
 let resize array new_size =
-  let old_size = Array.length array.buckets in
+  let old_size = Array.length array.methods in
   if new_size > old_size then begin
-    let new_buck = Array.create new_size empty_bucket in
-    Array.blit array.buckets 0 new_buck 0 old_size;
-    array.buckets <- new_buck
+    let new_buck = Array.create new_size null_item in
+    Array.blit array.methods 0 new_buck 0 old_size;
+    array.methods <- new_buck
  end
 
 let put array label element =
-  let (buck, elem) = decode label in
-  resize array (buck + 1);
-  let bucket = ref (array.buckets.(buck)) in
-  if !bucket == empty_bucket then begin
-    bucket := new_bucket ();
-    array.buckets.(buck) <- !bucket
-  end;
-  !bucket.(elem) <- element
+  resize array (label + 1);
+  array.methods.(label) <- element
 
 (**** Classes ****)
 
 let method_count = ref 0
 let inst_var_count = ref 0
 
-type t
+(* type t *)
 type meth = item
 
+let new_method table =
+  let index = Array.length table.methods in
+  resize table (index + 1);
+  index
+
 let get_method_label table name =
   try
     Meths.find name table.methods_by_name
   with Not_found ->
-    let label = new_anonymous_method () in
+    let label = new_method table in
     table.methods_by_name <- Meths.add name label table.methods_by_name;
     table.methods_by_label <- Labs.add label true table.methods_by_label;
     label
 
+let get_method_labels table names =
+  Array.map (get_method_label table) names
+
 let set_method table label element =
   incr method_count;
   if Labs.find label table.methods_by_label then
@@ -323,11 +187,16 @@ let set_method table label element =
     table.hidden_meths <- (label, element) :: table.hidden_meths
 
 let get_method table label =
-  try List.assoc label table.hidden_meths with Not_found ->
-  let (buck, elem) = decode label in
-  table.buckets.(buck).(elem)
+  try List.assoc label table.hidden_meths
+  with Not_found -> table.methods.(label)
+
+let to_list arr =
+  if arr == magic 0 then [] else Array.to_list arr
 
 let narrow table vars virt_meths concr_meths =
+  let vars = to_list vars
+  and virt_meths = to_list virt_meths
+  and concr_meths = to_list concr_meths in
   let virt_meth_labs = List.map (get_method_label table) virt_meths in
   let concr_meth_labs = List.map (get_method_label table) concr_meths in
   table.previous_states <-
@@ -387,35 +256,79 @@ let new_variable table name =
   table.vars <- Vars.add name index table.vars;
   index
 
+let new_variables table names =
+  let index = new_variable table names.(0) in
+  for i = 1 to Array.length names - 1 do
+    ignore (new_variable table names.(i))
+  done;
+  index
+
 let get_variable table name =
   Vars.find name table.vars
 
+let get_variables table names =
+  Array.map (get_variable table) names
+
 let add_initializer table f =
   table.initializers <- f::table.initializers
 
+(*
+module Keys = Map.Make(struct type t = tag array let compare = compare end)
+let key_map = ref Keys.empty
+let get_key tags : item =
+  try magic (Keys.find tags !key_map : tag array)
+  with Not_found ->
+    key_map := Keys.add tags tags !key_map;
+    magic tags
+*)
+
 let create_table public_methods =
-  let table = new_table () in
-  List.iter
-    (function met ->
-       let lab = new_method met in
-       table.methods_by_name  <- Meths.add met lab table.methods_by_name;
-       table.methods_by_label <- Labs.add lab true table.methods_by_label)
+  if public_methods == magic 0 then new_table [||] else
+  (* [public_methods] must be in ascending order for bytecode *)
+  let tags = Array.map public_method_label public_methods in
+  let table = new_table tags in
+  Array.iteri
+    (fun i met ->
+      let lab = i*2+2 in
+      table.methods_by_name  <- Meths.add met lab table.methods_by_name;
+      table.methods_by_label <- Labs.add lab true table.methods_by_label)
     public_methods;
   table
 
 let init_class table =
   inst_var_count := !inst_var_count + table.size - 1;
-  if params.compact_table then
-    compact_buckets table.buckets;
-  table.initializers <- List.rev table.initializers
+  table.initializers <- List.rev table.initializers;
+  resize table (3 + magic table.methods.(1) * 16 / Sys.word_size)
+
+let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
+  narrow cla vals virt_meths concr_meths;
+  let init =
+    if top then super cla env else Obj.repr (super cla) in
+  widen cla;
+  init
+
+let make_class pub_meths class_init =
+  let table = create_table pub_meths in
+  let env_init = class_init table in
+  init_class table;
+  (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
+
+type init_table = { mutable env_init: t; mutable class_init: table -> t }
+
+let make_class_store pub_meths class_init init_table =
+  let table = create_table pub_meths in
+  let env_init = class_init table in
+  init_class table;
+  init_table.class_init <- class_init;
+  init_table.env_init <- env_init
 
 (**** Objects ****)
 
 let create_object table =
   (* XXX Appel de [obj_block] *)
   let obj = Obj.new_block Obj.object_tag table.size in
-  (* XXX Appel de [modify] *)
-  Obj.set_field obj 0 (Obj.repr table.buckets);
+  (* XXX Appel de [caml_modify] *)
+  Obj.set_field obj 0 (Obj.repr table.methods);
   set_id obj last_id;
   (Obj.obj obj)
 
@@ -423,8 +336,8 @@ let create_object_opt obj_0 table =
   if (Obj.magic obj_0 : bool) then obj_0 else begin
     (* XXX Appel de [obj_block] *)
     let obj = Obj.new_block Obj.object_tag table.size in
-    (* XXX Appel de [modify] *)
-    Obj.set_field obj 0 (Obj.repr table.buckets);
+    (* XXX Appel de [caml_modify] *)
+    Obj.set_field obj 0 (Obj.repr table.methods);
     set_id obj last_id;
     (Obj.obj obj)
   end
@@ -453,42 +366,197 @@ let create_object_and_run_initializers obj_0 table =
     obj
   end
 
-let send obj lab =
-  let (buck, elem) = decode lab in
-  (magic obj : (obj -> t) array array array).(0).(buck).(elem) obj
+(* Equivalent primitive below
+let sendself obj lab =
+  (magic obj : (obj -> t) array array).(0).(lab) obj
+*)
+external send : obj -> tag -> 'a = "%send"
+external sendcache : obj -> tag -> t -> int -> 'a = "%sendcache"
+external sendself : obj -> label -> 'a = "%sendself"
+external get_public_method : obj -> tag -> closure
+    = "caml_get_public_method" "noalloc"
+
+(**** table collection access ****)
+
+type tables = Empty | Cons of closure * tables * tables
+type mut_tables =
+    {key: closure; mutable data: tables; mutable next: tables}
+external mut : tables -> mut_tables = "%identity"
+
+let build_path n keys tables =
+  let res = Cons (Obj.magic 0, Empty, Empty) in
+  let r = ref res in
+  for i = 0 to n do
+    r := Cons (keys.(i), !r, Empty)
+  done;
+  tables.data <- !r;
+  res
+
+let rec lookup_keys i keys tables =
+  if i < 0 then tables else
+  let key = keys.(i) in
+  let rec lookup_key tables =
+    if tables.key == key then lookup_keys (i-1) keys tables.data else
+    if tables.next <> Empty then lookup_key (mut tables.next) else
+    let next = Cons (key, Empty, Empty) in
+    tables.next <- next;
+    build_path (i-1) keys (mut next)
+  in
+  lookup_key (mut tables)
+
+let lookup_tables root keys =
+  let root = mut root in
+  if root.data <> Empty then
+    lookup_keys (Array.length keys - 1) keys root.data
+  else
+    build_path (Array.length keys - 1) keys root
+
+(**** builtin methods ****)
+
+let get_const x = ret (fun obj -> x)
+let get_var n   = ret (fun obj -> Array.unsafe_get obj n)
+let get_env e n =
+  ret (fun obj ->
+    Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)
+let get_meth n  = ret (fun obj -> sendself obj n)
+let set_var n   = ret (fun obj x -> Array.unsafe_set obj n x)
+let app_const f x = ret (fun obj -> f x)
+let app_var f n   = ret (fun obj -> f (Array.unsafe_get obj n))
+let app_env f e n =
+  ret (fun obj ->
+    f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n))
+let app_meth f n  = ret (fun obj -> f (sendself obj n))
+let app_const_const f x y = ret (fun obj -> f x y)
+let app_const_var f x n   = ret (fun obj -> f x (Array.unsafe_get obj n))
+let app_const_meth f x n = ret (fun obj -> f x (sendself obj n))
+let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x)
+let app_meth_const f n x = ret (fun obj -> f (sendself obj n) x)
+let app_const_env f x e n =
+  ret (fun obj ->
+    f x (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n))
+let app_env_const f e n x =
+  ret (fun obj ->
+    f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) x)
+let meth_app_const n x = ret (fun obj -> (sendself obj n) x)
+let meth_app_var n m =
+  ret (fun obj -> (sendself obj n) (Array.unsafe_get obj m))
+let meth_app_env n e m =
+  ret (fun obj -> (sendself obj n)
+      (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) m))
+let meth_app_meth n m =
+  ret (fun obj -> (sendself obj n) (sendself obj m))
+let send_const m x c =
+  ret (fun obj -> sendcache x m (Array.unsafe_get obj 0) c)
+let send_var m n c =
+  ret (fun obj ->
+    sendcache (Obj.magic (Array.unsafe_get obj n) : obj) m
+      (Array.unsafe_get obj 0) c)
+let send_env m e n c =
+  ret (fun obj ->
+    sendcache
+      (Obj.magic (Array.unsafe_get
+                    (Obj.magic (Array.unsafe_get obj e) : obj) n) : obj)
+      m (Array.unsafe_get obj 0) c)
+let send_meth m n c =
+  ret (fun obj ->
+    sendcache (sendself obj n) m (Array.unsafe_get obj 0) c)
+let new_cache table =
+  let n = new_method table in
+  let n =
+    if n mod 2 = 0 || n > 2 + magic table.methods.(1) * 16 / Sys.word_size
+    then n else new_method table
+  in
+  table.methods.(n) <- Obj.magic 0;
+  n
+
+type impl =
+    GetConst
+  | GetVar
+  | GetEnv
+  | GetMeth
+  | SetVar
+  | AppConst
+  | AppVar
+  | AppEnv
+  | AppMeth
+  | AppConstConst
+  | AppConstVar
+  | AppConstEnv
+  | AppConstMeth
+  | AppVarConst
+  | AppEnvConst
+  | AppMethConst
+  | MethAppConst
+  | MethAppVar
+  | MethAppEnv
+  | MethAppMeth
+  | SendConst
+  | SendVar
+  | SendEnv
+  | SendMeth
+  | Closure of closure
+
+let method_impl table i arr =
+  let next () = incr i; magic arr.(!i) in
+  match next() with
+    GetConst -> let x : t = next() in get_const x
+  | GetVar   -> let n = next() in get_var n
+  | GetEnv   -> let e = next() and n = next() in get_env e n
+  | GetMeth  -> let n = next() in get_meth n
+  | SetVar   -> let n = next() in set_var n
+  | AppConst -> let f = next() and x = next() in app_const f x
+  | AppVar   -> let f = next() and n = next () in app_var f n
+  | AppEnv   ->
+      let f = next() and e = next() and n = next() in app_env f e n
+  | AppMeth  -> let f = next() and n = next () in app_meth f n
+  | AppConstConst ->
+      let f = next() and x = next() and y = next() in app_const_const f x y
+  | AppConstVar ->
+      let f = next() and x = next() and n = next() in app_const_var f x n
+  | AppConstEnv ->
+      let f = next() and x = next() and e = next () and n = next() in
+      app_const_env f x e n
+  | AppConstMeth ->
+      let f = next() and x = next() and n = next() in app_const_meth f x n
+  | AppVarConst ->
+      let f = next() and n = next() and x = next() in app_var_const f n x
+  | AppEnvConst ->
+      let f = next() and e = next () and n = next() and x = next() in
+      app_env_const f e n x
+  | AppMethConst ->
+      let f = next() and n = next() and x = next() in app_meth_const f n x
+  | MethAppConst ->
+      let n = next() and x = next() in meth_app_const n x
+  | MethAppVar ->
+      let n = next() and m = next() in meth_app_var n m
+  | MethAppEnv ->
+      let n = next() and e = next() and m = next() in meth_app_env n e m
+  | MethAppMeth ->
+      let n = next() and m = next() in meth_app_meth n m
+  | SendConst ->
+      let m = next() and x = next() in send_const m x (new_cache table)
+  | SendVar ->
+      let m = next() and n = next () in send_var m n (new_cache table)
+  | SendEnv ->
+      let m = next() and e = next() and n = next() in
+      send_env m e n (new_cache table)
+  | SendMeth ->
+      let m = next() and n = next () in send_meth m n (new_cache table)
+  | Closure _ as clo -> magic clo
+
+let set_methods table methods =
+  let len = Array.length methods and i = ref 0 in
+  while !i < len do
+    let label = methods.(!i) and clo = method_impl table i methods in
+    set_method table label clo;
+    incr i
+  done
 
 (**** Statistics ****)
 
 type stats =
-  { classes: int; labels: int; methods: int; inst_vars: int; buckets: int;
-    distrib : int array; small_bucket_count: int; small_bucket_max: int }
-
-let distrib () =
-  let d = Array.create 32 0 in
-  List.iter
-    (function b ->
-       let n = bucket_used b in
-       d.(n - 1) <- d.(n - 1) + 1)
-    !bucket_list;
-  d
+  { classes: int; methods: int; inst_vars: int; }
 
 let stats () =
-  { classes = !table_count; labels = !label_count;
-    methods = !method_count; inst_vars = !inst_var_count;
-    buckets = List.length !bucket_list; distrib = distrib ();
-    small_bucket_count = !small_bucket_count;
-    small_bucket_max = Array.length !small_buckets  }
-
-let sort_buck lst =
-  List.map snd
-    (Sort.list (fun (n, _) (n', _) -> n <= n')
-       (List.map (function b -> (bucket_used b, b)) lst))
-
-let show_buckets () =
-  List.iter
-    (function b ->
-       for i = 0 to bucket_size - 1 do
-         print_char (if b.(i) == dummy_item then '.' else '*')
-       done;
-       print_newline ())
-    (sort_buck !bucket_list)
+  { classes = !table_count;
+    methods = !method_count; inst_vars = !inst_var_count; }
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index 15cad215..48d2ecb1 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -11,35 +11,47 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: camlinternalOO.mli,v 1.3 2003/06/19 15:53:51 xleroy Exp $ *)
+(* $Id: camlinternalOO.mli,v 1.6 2004/05/26 11:10:51 garrigue Exp $ *)
 
 (** Run-time support for objects and classes.
     All functions in this module are for system use only, not for the
     casual user. *)
 
-(** {6 Methods} *)
-
-type label
-val new_method : string -> label
-val public_method_label : string -> label
-
 (** {6 Classes} *)
 
+type tag
+type label
 type table
 type meth
 type t
 type obj
+type closure
+val public_method_label : string -> tag
+val new_method : table -> label
 val new_variable : table -> string -> int
+val new_variables : table -> string array -> int
 val get_variable : table -> string -> int
+val get_variables : table -> string array -> int array
 val get_method_label : table -> string -> label
+val get_method_labels : table -> string array -> label array
 val get_method : table -> label -> meth
 val set_method : table -> label -> meth -> unit
-val narrow : table -> string list -> string list -> string list -> unit
+val set_methods : table -> label array -> unit
+val narrow : table -> string array -> string array -> string array -> unit
 val widen : table -> unit
 val add_initializer : table -> (obj -> unit) -> unit
 val dummy_table : table
-val create_table : string list -> table
+val create_table : string array -> table
 val init_class : table -> unit
+val inherits :
+    table -> string array -> string array -> string array ->
+    (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t
+val make_class :
+    string array -> (table -> Obj.t -> t) ->
+    (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
+type init_table
+val make_class_store :
+    string array -> (table -> t) -> init_table -> unit
 
 (** {6 Objects} *)
 
@@ -49,10 +61,74 @@ val create_object_opt : obj -> table -> obj
 val run_initializers : obj -> table -> unit
 val run_initializers_opt : obj -> obj -> table -> obj
 val create_object_and_run_initializers : obj -> table -> obj
-val send : obj -> label -> t
+external send : obj -> tag -> t = "%send"
+external sendcache : obj -> tag -> t -> int -> t = "%sendcache"
+external sendself : obj -> label -> t = "%sendself"
+external get_public_method : obj -> tag -> closure
+    = "caml_get_public_method" "noalloc"
+
+(** {6 Table cache} *)
+
+type tables
+val lookup_tables : tables -> closure array -> tables
+
+(** {6 Builtins to reduce code size} *)
+
+val get_const : t -> closure
+val get_var : int -> closure
+val get_env : int -> int -> closure
+val get_meth : label -> closure
+val set_var : int -> closure
+val app_const : (t -> t) -> t -> closure
+val app_var : (t -> t) -> int -> closure
+val app_env : (t -> t) -> int -> int -> closure
+val app_meth : (t -> t) -> label -> closure
+val app_const_const : (t -> t -> t) -> t -> t -> closure
+val app_const_var : (t -> t -> t) -> t -> int -> closure
+val app_const_env : (t -> t -> t) -> t -> int -> int -> closure
+val app_const_meth : (t -> t -> t) -> t -> label -> closure
+val app_var_const : (t -> t -> t) -> int -> t -> closure
+val app_env_const : (t -> t -> t) -> int -> int -> t -> closure
+val app_meth_const : (t -> t -> t) -> label -> t -> closure
+val meth_app_const : label -> t -> closure
+val meth_app_var : label -> int -> closure
+val meth_app_env : label -> int -> int -> closure
+val meth_app_meth : label -> label -> closure
+val send_const : tag -> obj -> int -> closure
+val send_var : tag -> int -> int -> closure
+val send_env : tag -> int -> int -> int -> closure
+val send_meth : tag -> label -> int -> closure
+
+type impl =
+    GetConst
+  | GetVar
+  | GetEnv
+  | GetMeth
+  | SetVar
+  | AppConst
+  | AppVar
+  | AppEnv
+  | AppMeth
+  | AppConstConst
+  | AppConstVar
+  | AppConstEnv
+  | AppConstMeth
+  | AppVarConst
+  | AppEnvConst
+  | AppMethConst
+  | MethAppConst
+  | MethAppVar
+  | MethAppEnv
+  | MethAppMeth
+  | SendConst
+  | SendVar
+  | SendEnv
+  | SendMeth
+  | Closure of closure
 
 (** {6 Parameters} *)
 
+(* currently disabled *)
 type params =
   { mutable compact_table : bool;
     mutable copy_parent : bool;
@@ -66,12 +142,6 @@ val params : params
 
 type stats =
   { classes : int; 
-    labels : int; 
     methods : int; 
-    inst_vars : int; 
-    buckets : int;
-    distrib : int array; 
-    small_bucket_count : int; 
-    small_bucket_max : int }
+    inst_vars : int }
 val stats : unit -> stats
-val show_buckets : unit -> unit
diff --git a/stdlib/char.ml b/stdlib/char.ml
index 5b8bc354..f3819add 100644
--- a/stdlib/char.ml
+++ b/stdlib/char.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: char.ml,v 1.11 2002/06/26 09:13:58 xleroy Exp $ *)
+(* $Id: char.ml,v 1.12 2003/12/16 18:09:43 doligez Exp $ *)
 
 (* Character operations *)
 
@@ -21,9 +21,9 @@ external unsafe_chr: int -> char = "%identity"
 let chr n =
   if n < 0 or n > 255 then invalid_arg "Char.chr" else unsafe_chr n
 
-external is_printable: char -> bool = "is_printable"
+external is_printable: char -> bool = "caml_is_printable"
 
-external string_create: int -> string = "create_string"
+external string_create: int -> string = "caml_create_string"
 external string_unsafe_get : string -> int -> char = "%string_unsafe_get"
 external string_unsafe_set : string -> int -> char -> unit
                            = "%string_unsafe_set"
diff --git a/stdlib/digest.ml b/stdlib/digest.ml
index 7d1dcfc0..39a8d3df 100644
--- a/stdlib/digest.ml
+++ b/stdlib/digest.ml
@@ -11,14 +11,14 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: digest.ml,v 1.9 2002/07/12 09:47:53 xleroy Exp $ *)
+(* $Id: digest.ml,v 1.10 2003/12/31 14:20:39 doligez Exp $ *)
 
 (* Message digest (MD5) *)
 
 type t = string
 
-external unsafe_string: string -> int -> int -> t = "md5_string"
-external channel: in_channel -> int -> t = "md5_chan"
+external unsafe_string: string -> int -> int -> t = "caml_md5_string"
+external channel: in_channel -> int -> t = "caml_md5_chan"
 
 let string str =
   unsafe_string str 0 (String.length str)
diff --git a/stdlib/digest.mli b/stdlib/digest.mli
index 556f4eae..cabad34a 100644
--- a/stdlib/digest.mli
+++ b/stdlib/digest.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: digest.mli,v 1.15 2002/04/18 07:27:42 garrigue Exp $ *)
+(* $Id: digest.mli,v 1.16 2003/12/31 14:20:39 doligez Exp $ *)
 
 (** MD5 message digest.
 
@@ -32,7 +32,7 @@ val substring : string -> int -> int -> t
    of [s] starting at character number [ofs] and containing [len]
    characters. *)
 
-external channel : in_channel -> int -> t = "md5_chan"
+external channel : in_channel -> int -> t = "caml_md5_chan"
 (** If [len] is nonnegative, [Digest.channel ic len] reads [len]
    characters from channel [ic] and returns their digest, or raises
    [End_of_file] if end-of-file is reached before [len] characters
diff --git a/stdlib/filename.ml b/stdlib/filename.ml
index ec6e0b2f..09b9dd19 100644
--- a/stdlib/filename.ml
+++ b/stdlib/filename.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: filename.ml,v 1.30 2003/07/07 09:07:45 xleroy Exp $ *)
+(* $Id: filename.ml,v 1.34 2004/05/30 09:41:53 xleroy Exp $ *)
 
 let generic_quote quotequote s =
   let l = String.length s in
@@ -28,11 +28,9 @@ let generic_quote quotequote s =
 module Unix = struct
   let current_dir_name = "."
   let parent_dir_name = ".."
-  let concat dirname filename =
-    let l = String.length dirname in
-    if l = 0 || dirname.[l-1] = '/'
-    then dirname ^ filename
-    else dirname ^ "/" ^ filename
+  let dir_sep = "/"
+  let is_dir_sep s i = s.[i] = '/'
+  let rindex_dir_sep s = String.rindex s '/'
   let is_relative n = String.length n < 1 || n.[0] <> '/';;
   let is_implicit n =
     is_relative n
@@ -42,19 +40,6 @@ module Unix = struct
     String.length name >= String.length suff &&
     String.sub name (String.length name - String.length suff)
                     (String.length suff) = suff
-  let basename name =
-    try
-      let p = String.rindex name '/' + 1 in
-      String.sub name p (String.length name - p)
-    with Not_found ->
-      name
-  let dirname name =
-    try
-      match String.rindex name '/' with
-        0 -> "/"
-      | n -> String.sub name 0 n
-    with Not_found ->
-      "."
   let temporary_directory =
     try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
   let quote = generic_quote "'\\''"  
@@ -63,11 +48,14 @@ end
 module Win32 = struct
   let current_dir_name = "."
   let parent_dir_name = ".."
-  let concat dirname filename =
-    let l = String.length dirname in
-    if l = 0 || (let c = dirname.[l-1] in c = '/' || c = '\\' || c = ':')
-    then dirname ^ filename
-    else dirname ^ "\\" ^ filename
+  let dir_sep = "\\"
+  let is_dir_sep s i = let c = s.[i] in c = '/' || c = '\\' || c = ':'
+  let rindex_dir_sep s =
+    let rec pos i =
+      if i < 0 then raise Not_found
+      else if (let c = s.[i] in c = '/' || c = '\\' || c = ':') then i
+      else pos (i - 1)
+    in pos (String.length s - 1)
   let is_relative n =
     (String.length n < 1 || n.[0] <> '/')
     && (String.length n < 1 || n.[0] <> '\\')
@@ -83,29 +71,6 @@ module Win32 = struct
    (let s = String.sub name (String.length name - String.length suff)
                             (String.length suff) in
     String.lowercase s = String.lowercase suff)
-  let rindexsep s =
-    let rec pos i =
-      if i < 0 then raise Not_found
-      else if (let c = s.[i] in c = '/' || c = '\\' || c = ':') then i
-      else pos (i - 1)
-    in pos (String.length s - 1)
-  let basename name =
-    try
-      let p = rindexsep name + 1 in
-      String.sub name p (String.length name - p)
-    with Not_found ->
-      name
-  let dirname name =
-    try
-      match rindexsep name with
-        0 -> "\\"
-      | n ->
-          let n =
-            if name.[n] = ':' || (n > 0 && name.[n-1] = ':')
-            then n+1 else n in
-          String.sub name 0 n
-    with Not_found ->
-      "."
   let temporary_directory =
     try Sys.getenv "TEMP" with Not_found -> "."
   let quote s =
@@ -127,93 +92,70 @@ end
 module Cygwin = struct
   let current_dir_name = "."
   let parent_dir_name = ".."
-  let concat dirname filename =
-    let l = String.length dirname in
-    if l = 0 || (let c = dirname.[l-1] in c = '/' || c = '\\' || c = ':')
-    then dirname ^ filename
-    else dirname ^ "/" ^ filename
+  let dir_sep = "/"
+  let is_dir_sep = Win32.is_dir_sep
+  let rindex_dir_sep = Win32.rindex_dir_sep
   let is_relative = Win32.is_relative
   let is_implicit = Win32.is_implicit
   let check_suffix = Win32.check_suffix
-  let basename = Win32.basename
-  let dirname name =
-    try
-      match Win32.rindexsep name with
-        0 -> "/"
-      | n ->
-          let n =
-            if name.[n] = ':' || (n > 0 && name.[n-1] = ':')
-            then n+1 else n in
-          String.sub name 0 n
-    with Not_found ->
-      "."
   let temporary_directory = Unix.temporary_directory
   let quote = Unix.quote
 end
 
-module MacOS = struct
-  let current_dir_name = "."
-  let parent_dir_name = ".."
-  let concat dirname filename =
-    let l = String.length dirname in
-    if l = 0 || dirname.[l-1] = ':'
-    then dirname ^ filename
-    else dirname ^ ":" ^ filename
-  let contains_colon n = String.contains n ':'
-  let is_relative n =
-    (String.length n >= 1 && n.[0] = ':')
-    || not (contains_colon n)
-  let is_implicit n = not (contains_colon n)
-  let check_suffix = Unix.check_suffix
-  let basename name =
-    try
-      let p = String.rindex name ':' + 1 in
-      String.sub name p (String.length name - p)
-    with Not_found -> name
-  let dirname name =
-    try match String.rindex name ':' with
-        | 0 -> ":"
-        | n -> String.sub name 0 n
-    with Not_found -> ":"
-  let temporary_directory =
-    try Sys.getenv "TempFolder" with Not_found -> ":"
-  let quote = generic_quote "'\182''"
-end
-
-let (current_dir_name, parent_dir_name, concat, is_relative, is_implicit,
-     check_suffix, basename, dirname, temporary_directory, quote) =
+let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, rindex_dir_sep,
+     is_relative, is_implicit, check_suffix, temporary_directory, quote) =
   match Sys.os_type with
     "Unix" ->
-      (Unix.current_dir_name, Unix.parent_dir_name, Unix.concat,
+      (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep, 
+       Unix.is_dir_sep, Unix.rindex_dir_sep,
        Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
-       Unix.basename, Unix.dirname, Unix.temporary_directory, Unix.quote)
+       Unix.temporary_directory, Unix.quote)
   | "Win32" ->
-      (Win32.current_dir_name, Win32.parent_dir_name, Win32.concat,
+      (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep, 
+       Win32.is_dir_sep, Win32.rindex_dir_sep,
        Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
-       Win32.basename, Win32.dirname, Win32.temporary_directory, Win32.quote)
+       Win32.temporary_directory, Win32.quote)
   | "Cygwin" ->
-      (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.concat,
+      (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep, 
+       Cygwin.is_dir_sep, Cygwin.rindex_dir_sep,
        Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
-       Cygwin.basename, Cygwin.dirname, 
        Cygwin.temporary_directory, Cygwin.quote)
-  | "MacOS" ->
-      (MacOS.current_dir_name, MacOS.parent_dir_name, MacOS.concat,
-       MacOS.is_relative, MacOS.is_implicit, MacOS.check_suffix,
-       MacOS.basename, MacOS.dirname, MacOS.temporary_directory, MacOS.quote)
   | _ -> assert false
 
+let concat dirname filename =
+  let l = String.length dirname in
+  if l = 0 || is_dir_sep dirname (l-1)
+  then dirname ^ filename
+  else dirname ^ dir_sep ^ filename
+
+let basename name =
+  try
+    let p = rindex_dir_sep name + 1 in
+    String.sub name p (String.length name - p)
+  with Not_found ->
+    name
+
+let dirname name =
+  try
+    match rindex_dir_sep name with
+      0 -> dir_sep
+    | n -> String.sub name 0 n
+  with Not_found ->
+    current_dir_name
+
 let chop_suffix name suff =
   let n = String.length name - String.length suff in
   if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n
 
 let chop_extension name =
-  try
-    String.sub name 0 (String.rindex name '.')
-  with Not_found ->
-    invalid_arg "Filename.chop_extension"
+  let rec search_dot i =
+    if i < 0 || is_dir_sep name i then invalid_arg "Filename.chop_extension"
+    else if name.[i] = '.' then String.sub name 0 i
+    else search_dot (i - 1) in
+  search_dot (String.length name - 1)
 
-external open_desc: string -> open_flag list -> int -> int = "sys_open"
-external close_desc: int -> unit = "sys_close"
+external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
+external close_desc: int -> unit = "caml_sys_close"
 
 let prng = Random.State.make_self_init ();;
 
diff --git a/stdlib/filename.mli b/stdlib/filename.mli
index 4b7db797..d1c831b4 100644
--- a/stdlib/filename.mli
+++ b/stdlib/filename.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: filename.mli,v 1.29 2002/11/02 21:47:59 doligez Exp $ *)
+(* $Id: filename.mli,v 1.31 2004/05/30 09:41:53 xleroy Exp $ *)
 
 (** Operations on file names. *)
 
@@ -48,10 +48,11 @@ val chop_suffix : string -> string -> string
 
 val chop_extension : string -> string
 (** Return the given file name without its extension. The extension
-   is the shortest suffix starting with a period, [.xyz] for instance.
+   is the shortest suffix starting with a period and not including
+   a directory separator, [.xyz] for instance.
 
    Raise [Invalid_argument] if the given name does not contain
-   a period. *)
+   an extension. *)
 
 val basename : string -> string
 (** Split a file name into directory name / base file name.
@@ -76,10 +77,7 @@ val temp_file : string -> string -> string
    Under Unix, the temporary directory is [/tmp] by default; if set,
    the value of the environment variable [TMPDIR] is used instead.
    Under Windows, the name of the temporary directory is the
-   value of the environment variable [TEMP], or [C:\temp] by default.
-   Under MacOS 9, the name of the temporary directory is given
-   by the environment variable [TempFolder]; if not set,
-   temporary files are created in the current directory. *)
+   value of the environment variable [TEMP], or [C:\temp] by default. *)
 
 val open_temp_file :
       ?mode: open_flag list -> string -> string -> string * out_channel
diff --git a/stdlib/format.ml b/stdlib/format.ml
index cc0355cc..96f45523 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: format.ml,v 1.50 2003/02/28 06:59:18 weis Exp $ *)
+(* $Id: format.ml,v 1.55.4.1 2004/07/02 22:24:22 weis Exp $ *)
 
 (**************************************************************
 
@@ -57,12 +57,12 @@ and tblock = Pp_tbox of int list ref  (* Tabulation box *)
    contains all formatting elements.
    elements are tuples (size, token, length), where
    size is set when the size of the block is known
-   len is the declared length of the token *)
+   len is the declared length of the token. *)
 type pp_queue_elem = {mutable elem_size : int; token : pp_token; length : int};;
 
 (* Scan stack:
    each element is (left_total, queue element) where left_total
-   is the value of pp_left_total when the element has been enqueued *)
+   is the value of pp_left_total when the element has been enqueued. *)
 type pp_scan_elem = Scan_elem of int * pp_queue_elem;;
 
 (* Formatting stack:
@@ -71,7 +71,7 @@ type pp_scan_elem = Scan_elem of int * pp_queue_elem;;
    the currently active blocks. *)
 type pp_format_elem = Format_elem of block_type * int;;
 
-(* General purpose queues, used in the formatter *)
+(* General purpose queues, used in the formatter. *)
 type 'a queue_elem = | Nil | Cons of 'a queue_cell
 and 'a queue_cell = {mutable head : 'a; mutable tail : 'a queue_elem};;
 
@@ -98,37 +98,37 @@ type formatter = {
  mutable pp_mark_stack : tag list;
  (* Global variables: default initialization is
     set_margin 78
-    set_min_space_left 0 *)
- (* Value of right margin *)
+    set_min_space_left 0. *)
+ (* Value of right margin. *)
  mutable pp_margin : int;
- (* Minimal space left before margin, when opening a block *)
+ (* Minimal space left before margin, when opening a block. *)
  mutable pp_min_space_left : int;
  (* Maximum value of indentation:
-    no blocks can be opened further *)
+    no blocks can be opened further. *)
  mutable pp_max_indent : int;
- (* Space remaining on the current line *)
+ (* Space remaining on the current line. *)
  mutable pp_space_left : int;
- (* Current value of indentation *)
+ (* Current value of indentation. *)
  mutable pp_current_indent : int;
- (* True when the line has been broken by the pretty-printer *)
+ (* True when the line has been broken by the pretty-printer. *)
  mutable pp_is_new_line : bool;
- (* Total width of tokens already printed *)
+ (* Total width of tokens already printed. *)
  mutable pp_left_total : int;
- (* Total width of tokens ever put in queue *)
+ (* Total width of tokens ever put in queue. *)
  mutable pp_right_total : int;
- (* Current number of opened blocks *)
+ (* Current number of opened blocks. *)
  mutable pp_curr_depth : int;
- (* Maximum number of blocks which can be simultaneously opened *)
+ (* Maximum number of blocks which can be simultaneously opened. *)
  mutable pp_max_boxes : int;
- (* Ellipsis string *)
+ (* Ellipsis string. *)
  mutable pp_ellipsis : string;
- (* Output function *)
+ (* Output function. *)
  mutable pp_output_function : string -> int -> int -> unit;
- (* Flushing function *)
+ (* Flushing function. *)
  mutable pp_flush_function : unit -> unit;
- (* Output of new lines *)
+ (* Output of new lines. *)
  mutable pp_output_newline : unit -> unit;
- (* Output of indentation spaces *)
+ (* Output of indentation spaces. *)
  mutable pp_output_spaces : int -> unit;
  (* Are tags printed ? *)
  mutable pp_print_tags : bool;
@@ -139,7 +139,7 @@ type formatter = {
  mutable pp_mark_close_tag : tag -> string;
  mutable pp_print_open_tag : tag -> unit;
  mutable pp_print_close_tag : tag -> unit;
- (* The pretty-printer queue *)
+ (* The pretty-printer queue. *)
  mutable pp_queue : pp_queue_elem queue
 };;
 
@@ -159,7 +159,7 @@ let add_queue x q =
  let c = Cons {head = x; tail = Nil} in
  match q with
  | {insert = Cons cell} -> q.insert <- c; cell.tail <- c
- (* Invariant: when insert is Nil body should be Nil *)
+ (* Invariant: when insert is Nil body should be Nil. *)
  | _ -> q.insert <- c; q.body <- c;;
 
 exception Empty_queue;;
@@ -171,11 +171,11 @@ let peek_queue = function
 let take_queue = function
  | {body = Cons {head = x; tail = tl}} as q ->
     q.body <- tl;
-    if tl = Nil then q.insert <- Nil; (* Maintain the invariant *)
+    if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *)
     x
  | _ -> raise Empty_queue;;
 
-(* Enter a token in the pretty-printer queue *)
+(* Enter a token in the pretty-printer queue. *)
 let pp_enqueue state ({length = len} as token) =
     state.pp_right_total <- state.pp_right_total + len;
     add_queue token state.pp_queue;;
@@ -184,32 +184,32 @@ let pp_clear_queue state =
     state.pp_left_total <- 1; state.pp_right_total <- 1;
     clear_queue state.pp_queue;;
 
-(* Large value for default tokens size *)
+(* Large value for default tokens size. *)
 (* Could be 1073741823 that is 2^30 - 1, that is the minimal upper bound
    of integers; now that max_int is defined, could also be max_int - 1. *)
-let pp_infinity = 999999999;;
+let pp_infinity = 1000000000;;
 
-(* Output functions for the formatter *)
+(* Output functions for the formatter. *)
 let pp_output_string state s = state.pp_output_function s 0 (String.length s)
 and pp_output_newline state = state.pp_output_newline ();;
 
 let pp_display_blanks state n = state.pp_output_spaces n;;
 
-(* To format a break, indenting a new line *)
+(* To format a break, indenting a new line. *)
 let break_new_line state offset width =
     pp_output_newline state;
     state.pp_is_new_line <- true;
     let indent = state.pp_margin - width + offset in
-    (* Don't indent more than pp_max_indent *)
+    (* Don't indent more than pp_max_indent. *)
     let real_indent = min state.pp_max_indent indent in
     state.pp_current_indent <- real_indent;
     state.pp_space_left <- state.pp_margin - state.pp_current_indent;
     pp_display_blanks state state.pp_current_indent;;
 
-(* To force a line break inside a block: no offset is added *)
+(* To force a line break inside a block: no offset is added. *)
 let break_line state width = break_new_line state 0 width;;
 
-(* To format a break that fits on the current line *)
+(* To format a break that fits on the current line. *)
 let break_same_line state width =
     state.pp_space_left <- state.pp_space_left - width;
     pp_display_blanks state width;;
@@ -225,9 +225,9 @@ let pp_force_break_line state =
           | Pp_fits -> () | Pp_hbox -> () | _ -> break_line state width)
     | _ -> pp_output_newline state;;
 
-(* To skip a token, if the previous line has been broken *)
+(* To skip a token, if the previous line has been broken. *)
 let pp_skip_token state =
-    (* When calling pp_skip_token the queue cannot be empty *)
+    (* When calling pp_skip_token the queue cannot be empty. *)
     match take_queue state.pp_queue with
     {elem_size = size; length = len} ->
        state.pp_left_total <- state.pp_left_total - len;
@@ -239,7 +239,7 @@ let pp_skip_token state =
 
  **************************************************************)
 
-(* To format a token *)
+(* To format a token. *)
 let format_pp_token state size = function
 
   | Pp_text s ->
@@ -250,7 +250,7 @@ let format_pp_token state size = function
   | Pp_begin (off, ty) ->
       let insertion_point = state.pp_margin - state.pp_space_left in
       if insertion_point > state.pp_max_indent then
-         (* can't open a block right there *)
+         (* can't open a block right there. *)
          begin pp_force_break_line state end;
       let offset = state.pp_space_left - off in
       let bl_type =
@@ -264,7 +264,7 @@ let format_pp_token state size = function
   | Pp_end ->
       begin match state.pp_format_stack with
         | x :: (y :: l as ls) -> state.pp_format_stack <- ls
-        | _ -> () (* No more block to close *)
+        | _ -> () (* No more block to close. *)
       end
 
   | Pp_tbegin (Pp_tbox _ as tbox) ->
@@ -273,7 +273,7 @@ let format_pp_token state size = function
   | Pp_tend ->
       begin match state.pp_tbox_stack with
         | x :: ls -> state.pp_tbox_stack <- ls
-        | _ -> () (* No more tabulation block to close *)
+        | _ -> () (* No more tabulation block to close. *)
       end
 
   | Pp_stab ->
@@ -283,7 +283,7 @@ let format_pp_token state size = function
           | [] -> [n]
           | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in
         tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs
-     | _ -> () (* No opened tabulation block *)
+     | _ -> () (* No opened tabulation block. *)
      end
 
   | Pp_tbreak (n, off) ->
@@ -301,7 +301,7 @@ let format_pp_token state size = function
          let offset = tab - insertion_point in
          if offset >= 0 then break_same_line state (offset + n) else
           break_new_line state (tab + off) state.pp_margin
-      | _ -> () (* No opened tabulation block *)
+      | _ -> () (* No opened tabulation block. *)
       end
 
   | Pp_newline ->
@@ -336,7 +336,7 @@ let format_pp_token state size = function
         | Pp_vbox -> break_new_line state off width
         | Pp_hbox -> break_same_line state n
         end
-     | _ -> () (* No opened block *)
+     | _ -> () (* No opened block. *)
      end
 
    | Pp_open_tag tag_name ->
@@ -350,13 +350,13 @@ let format_pp_token state size = function
           let marker = state.pp_mark_close_tag tag_name in
           pp_output_string state marker;
           state.pp_mark_stack <- tags
-      | _ -> () (* No more tag to close *)
+      | _ -> () (* No more tag to close. *)
       end;;
 
-(* Print if token size is known or printing is delayed
-   Size is known when not negative
+(* Print if token size is known or printing is delayed.
+   Size is known when not negative.
    Printing is delayed when the text waiting in the queue requires
-   more room to format than exists on the current line *)
+   more room to format than exists on the current line. *)
 let rec advance_left state =
     try
      match peek_queue state.pp_queue with
@@ -374,33 +374,33 @@ let rec advance_left state =
 
 let enqueue_advance state tok = pp_enqueue state tok; advance_left state;;
 
-(* To enqueue a string : try to advance *)
+(* To enqueue a string : try to advance. *)
 let enqueue_string_as state n s =
     enqueue_advance state {elem_size = n; token = Pp_text s; length = n};;
 
 let enqueue_string state s = enqueue_string_as state (String.length s) s;;
 
 (* Routines for scan stack
-   determine sizes of blocks *)
+   determine sizes of blocks. *)
 
-(* The scan_stack is never empty *)
+(* The scan_stack is never empty. *)
 let scan_stack_bottom =
     [Scan_elem (-1, {elem_size = (-1); token = Pp_text ""; length = 0})];;
 
 (* Set size of blocks on scan stack:
-   if ty = true then size of break is set else size of block is set
-   in each case pp_scan_stack is popped *)
+   if ty = true then size of break is set else size of block is set;
+   in each case pp_scan_stack is popped. *)
 let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;;
 
 (* Pattern matching on scan stack is exhaustive,
    since scan_stack is never empty.
    Pattern matching on token in scan stack is also exhaustive,
-   since scan_push is used on breaks and opening of boxes *)
+   since scan_push is used on breaks and opening of boxes. *)
 let set_size state ty =
     match state.pp_scan_stack with
     | Scan_elem (left_tot,
                  ({elem_size = size; token = tok} as queue_elem)) :: t ->
-       (* test if scan stack contains any data that is not obsolete *)
+       (* test if scan stack contains any data that is not obsolete. *)
        if left_tot < state.pp_left_total then clear_scan_stack state else
         begin match tok with
         | Pp_break (_, _) | Pp_tbreak (_, _) ->
@@ -415,11 +415,11 @@ let set_size state ty =
              queue_elem.elem_size <- state.pp_right_total + size;
              state.pp_scan_stack <- t
             end
-        | _ -> () (* scan_push is only used for breaks and boxes *)
+        | _ -> () (* scan_push is only used for breaks and boxes. *)
         end
-    | _ -> () (* scan_stack is never empty *);;
+    | _ -> () (* scan_stack is never empty. *);;
 
-(* Push a token on scan stack. If b is true set_size is called *)
+(* Push a token on scan stack. If b is true set_size is called. *)
 let scan_push state b tok =
     pp_enqueue state tok;
     if b then set_size state true;
@@ -428,7 +428,7 @@ let scan_push state b tok =
 
 (* To open a new block :
    the user may set the depth bound pp_max_boxes
-   any text nested deeper is printed as the ellipsis string *)
+   any text nested deeper is printed as the ellipsis string. *)
 let pp_open_box_gen state indent br_ty =
     state.pp_curr_depth <- state.pp_curr_depth + 1;
     if state.pp_curr_depth < state.pp_max_boxes then
@@ -438,14 +438,10 @@ let pp_open_box_gen state indent br_ty =
     if state.pp_curr_depth = state.pp_max_boxes
     then enqueue_string state state.pp_ellipsis;;
 
-(* The box which is always opened *)
-let pp_open_sys_box state =
-    state.pp_curr_depth <- state.pp_curr_depth + 1;
-    scan_push state false
-     {elem_size = (- state.pp_right_total);
-      token = Pp_begin (0, Pp_hovbox); length = 0};;
+(* The box which is always opened. *)
+let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox;;
 
-(* Close a block, setting sizes of its subblocks *)
+(* Close a block, setting sizes of its subblocks. *)
 let pp_close_box state () =
     if state.pp_curr_depth > 1 then
      begin
@@ -475,7 +471,7 @@ let pp_close_tag state () =
       | tag_name :: tags ->
           state.pp_print_close_tag tag_name;
           state.pp_tag_stack <- tags
-      | _ -> () (* No more tag to close *)
+      | _ -> () (* No more tag to close. *)
       end;;
 
 let pp_set_print_tags state b = state.pp_print_tags <- b;;
@@ -491,27 +487,28 @@ let pp_get_formatter_tag_functions state () = {
    print_close_tag = state.pp_print_close_tag;
 };;
 
-let pp_set_formatter_tag_functions state
-    {mark_open_tag = motag;
-     mark_close_tag = mctag;
-     print_open_tag = potag;
-     print_close_tag = pctag;} =
-  state.pp_mark_open_tag <- motag;
-  state.pp_mark_close_tag <- mctag;
-  state.pp_print_open_tag <- potag;
-  state.pp_print_close_tag <- pctag;;
+let pp_set_formatter_tag_functions state {
+     mark_open_tag = mot;
+     mark_close_tag = mct;
+     print_open_tag = pot;
+     print_close_tag = pct;
+  } =
+   state.pp_mark_open_tag <- mot;
+   state.pp_mark_close_tag <- mct;
+   state.pp_print_open_tag <- pot;
+   state.pp_print_close_tag <- pct;;
 
 (* Initialize pretty-printer. *)
 let pp_rinit state =
     pp_clear_queue state;
     clear_scan_stack state;
-    state.pp_current_indent <- 0;
-    state.pp_curr_depth <- 0;
-    state.pp_space_left <- state.pp_margin;
     state.pp_format_stack <- [];
     state.pp_tbox_stack <- [];
     state.pp_tag_stack <- [];
     state.pp_mark_stack <- [];
+    state.pp_current_indent <- 0;
+    state.pp_curr_depth <- 0;
+    state.pp_space_left <- state.pp_margin;
     pp_open_sys_box state;;
 
 (* Flushing pretty-printer queue. *)
@@ -519,7 +516,8 @@ let pp_flush_queue state b =
     while state.pp_curr_depth > 1 do
      pp_close_box state ()
     done;
-    state.pp_right_total <- pp_infinity; advance_left state;
+    state.pp_right_total <- pp_infinity;
+    advance_left state;
     if b then pp_output_newline state;
     pp_rinit state;;
 
@@ -529,27 +527,27 @@ let pp_flush_queue state b =
 
  **************************************************************)
 
-(* To format a string *)
+(* To format a string. *)
 let pp_print_as state n s =
   if state.pp_curr_depth < state.pp_max_boxes
   then enqueue_string_as state n s;;
 
 let pp_print_string state s = pp_print_as state (String.length s) s;;
 
-(* To format an integer *)
+(* To format an integer. *)
 let pp_print_int state i = pp_print_string state (string_of_int i);;
 
-(* To format a float *)
+(* To format a float. *)
 let pp_print_float state f = pp_print_string state (string_of_float f);;
 
-(* To format a boolean *)
+(* To format a boolean. *)
 let pp_print_bool state b = pp_print_string state (string_of_bool b);;
 
-(* To format a char *)
+(* To format a char. *)
 let pp_print_char state c =
   let s = String.create 1 in s.[0] <- c; pp_print_as state 1 s;;
 
-(* Opening boxes *)
+(* Opening boxes. *)
 let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox
 and pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox
 
@@ -558,18 +556,18 @@ and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox
 and pp_open_box state indent = pp_open_box_gen state indent Pp_box;;
 
 (* Print a new line after printing all queued text
-   (same for print_flush but without a newline).    *)
+   (same for print_flush but without a newline). *)
 let pp_print_newline state () =
     pp_flush_queue state true; state.pp_flush_function ()
 and pp_print_flush state () =
     pp_flush_queue state false; state.pp_flush_function ();;
 
-(* To get a newline when one does not want to close the current block *)
+(* To get a newline when one does not want to close the current block. *)
 let pp_force_newline state () =
   if state.pp_curr_depth < state.pp_max_boxes then
     enqueue_advance state {elem_size = 0; token = Pp_newline; length = 0};;
 
-(* To format something if the line has just been broken *)
+(* To format something if the line has just been broken. *)
 let pp_print_if_newline state () =
   if state.pp_curr_depth < state.pp_max_boxes then
     enqueue_advance state {elem_size = 0; token = Pp_if_newline; length = 0};;
@@ -577,7 +575,7 @@ let pp_print_if_newline state () =
 (* Breaks: indicate where a block may be broken.
    If line is broken then offset is added to the indentation of the current
    block else (the value of) width blanks are printed.
-   To do (?) : add a maximum width and offset value *)
+   To do (?) : add a maximum width and offset value. *)
 let pp_print_break state width offset =
   if state.pp_curr_depth < state.pp_max_boxes then
     scan_push state true
@@ -587,7 +585,7 @@ let pp_print_break state width offset =
 let pp_print_space state () = pp_print_break state 1 0
 and pp_print_cut state () = pp_print_break state 0 0;;
 
-(* Tabulation boxes *)
+(* Tabulation boxes. *)
 let pp_open_tbox state () =
   state.pp_curr_depth <- state.pp_curr_depth + 1;
   if state.pp_curr_depth < state.pp_max_boxes then
@@ -595,14 +593,14 @@ let pp_open_tbox state () =
       {elem_size = 0;
        token = Pp_tbegin (Pp_tbox (ref [])); length = 0};;
 
-(* Close a tabulation block *)
+(* Close a tabulation block. *)
 let pp_close_tbox state () =
   if state.pp_curr_depth > 1 then begin
    if state.pp_curr_depth < state.pp_max_boxes then
     enqueue_advance state {elem_size = 0; token = Pp_tend; length = 0};
    state.pp_curr_depth <- state.pp_curr_depth - 1 end;;
 
-(* Print a tabulation break *)
+(* Print a tabulation break. *)
 let pp_print_tbreak state width offset =
   if state.pp_curr_depth < state.pp_max_boxes then
     scan_push state true
@@ -621,19 +619,19 @@ let pp_set_tab state () =
 
  **************************************************************)
 
-(* Fit max_boxes *)
+(* Fit max_boxes. *)
 let pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n;;
 
-(* To know the current maximum number of boxes allowed *)
+(* To know the current maximum number of boxes allowed. *)
 let pp_get_max_boxes state () = state.pp_max_boxes;;
 
 let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes;;
 
-(* Ellipsis *)
+(* Ellipsis. *)
 let pp_set_ellipsis_text state s = state.pp_ellipsis <- s
 and pp_get_ellipsis_text state () = state.pp_ellipsis;;
 
-(* To set the margin of pretty-printer *)
+(* To set the margin of pretty-printer. *)
 let pp_set_min_space_left state n =
   if n >= 1 && n < pp_infinity then begin
     state.pp_min_space_left <- n;
@@ -642,7 +640,7 @@ let pp_set_min_space_left state n =
 
 (* Initially, we have :
   pp_max_indent = pp_margin - pp_min_space_left, and
-  pp_space_left = pp_margin *)
+  pp_space_left = pp_margin. *)
 let pp_set_max_indent state n =
   pp_set_min_space_left state (state.pp_margin - n);;
 let pp_get_max_indent state () = state.pp_max_indent;;
@@ -651,17 +649,20 @@ let pp_set_margin state n =
   if n >= 1 && n < pp_infinity then begin
     state.pp_margin <- n;
     let new_max_indent =
-        (* Try to maintain max_indent to its actual value *)
+        (* Try to maintain max_indent to its actual value. *)
         if state.pp_max_indent <= state.pp_margin
         then state.pp_max_indent else
         (* If possible maintain pp_min_space_left to its actual value,
            if this leads to a too small max_indent, take half of the
-           new margin, if it is greater than 1 *)
+           new margin, if it is greater than 1. *)
          max (max (state.pp_margin - state.pp_min_space_left)
                   (state.pp_margin / 2)) 1 in
-    (* Rebuild invariants *)
+    (* Rebuild invariants. *)
     pp_set_max_indent state new_max_indent end;;
 
+let pp_set_margin_to_max state () =
+  pp_set_margin state (pp_infinity - 1);;
+
 let pp_get_margin state () = state.pp_margin;;
 
 let pp_set_formatter_output_functions state f g =
@@ -695,7 +696,7 @@ let default_pp_print_open_tag s = ();;
 let default_pp_print_close_tag = default_pp_print_open_tag;;
 
 let pp_make_formatter f g h i =
- (* The initial state of the formatter contains a dummy box *)
+ (* The initial state of the formatter contains a dummy box. *)
  let pp_q = make_queue () in
  let sys_tok =
      {elem_size = (- 1); token = Pp_begin (0, Pp_hovbox); length = 0} in
@@ -731,7 +732,7 @@ let pp_make_formatter f g h i =
   pp_queue = pp_q
  };;
 
-(* Default function to output spaces *)
+(* Default function to output spaces. *)
 let blank_line = String.make 80 ' ';;
 let rec display_blanks state n =
     if n > 0 then
@@ -741,7 +742,7 @@ let rec display_blanks state n =
       display_blanks state (n - 80)
      end;;
 
-(* Default function to output new lines *)
+(* Default function to output new lines. *)
 let display_newline state () = state.pp_output_function "\n" 0  1;;
 
 let make_formatter f g =
@@ -753,7 +754,7 @@ let make_formatter f g =
 let formatter_of_out_channel oc =
   make_formatter (output oc) (fun () -> flush oc);;
 
-let unit_out () = ();;
+let unit_out ppf = ();;
 
 let formatter_of_buffer b =
   make_formatter (Buffer.add_substring b) unit_out;;
@@ -806,6 +807,7 @@ and set_tab = pp_set_tab std_formatter
 and print_tab = pp_print_tab std_formatter
 
 and set_margin = pp_set_margin std_formatter
+and set_margin_to_max = pp_set_margin_to_max std_formatter
 and get_margin = pp_get_margin std_formatter
 
 and set_max_indent = pp_set_max_indent std_formatter
@@ -893,7 +895,7 @@ let string_out b ppf =
  get_buffer_out b;;
 
 (* Applies [printer] to a formatter that outputs on a fresh buffer,
-   then returns the resulting material *)
+   then returns the resulting material. *)
 let exstring printer arg =
  let b = Buffer.create 512 in
  let ppf = formatter_of_buffer b in
@@ -934,7 +936,7 @@ let fprintf_out str out ppf format =
 
   let rec doprn i =
     if i >= limit then
-      Obj.magic (out ())
+      Obj.magic (out ppf)
     else
       match format.[i] with
       | '%' ->
@@ -1115,18 +1117,22 @@ let fprintf_out str out ppf format =
 
  **************************************************************)
 
-let fprintf ppf = fprintf_out false unit_out ppf;;
+let kfprintf k = fprintf_out false k;;
+let fprintf ppf = kfprintf unit_out ppf;;
 let printf f = fprintf std_formatter f;;
 let eprintf f = fprintf err_formatter f;;
 
-let kprintf k =
- let b = Buffer.create 512 in
+let bprintf b =
  let ppf = formatter_of_buffer b in
- fprintf_out true (fun () -> k (string_out b ppf)) ppf;;
-let sprintf f = kprintf (fun x -> x) f;;
+ kfprintf (fun ppf -> pp_flush_queue ppf false) ppf;;
 
-let bprintf b =
+let ksprintf k =
+ let b = Buffer.create 512 in
  let ppf = formatter_of_buffer b in
- fprintf_out false (fun () -> pp_flush_queue ppf false) ppf;;
+ fprintf_out true (fun ppf -> k (string_out b ppf)) ppf;;
+
+let sprintf f = ksprintf (fun s -> s) f;;
+
+let kprintf = ksprintf;;
 
 at_exit print_flush;;
diff --git a/stdlib/format.mli b/stdlib/format.mli
index 650e9cfc..b8ef7cc6 100644
--- a/stdlib/format.mli
+++ b/stdlib/format.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: format.mli,v 1.63 2003/09/25 10:33:52 weis Exp $ *)
+(* $Id: format.mli,v 1.66.2.1 2004/07/02 22:24:22 weis Exp $ *)
 
 (** Pretty printing.
 
@@ -20,6 +20,9 @@
    at specified break hints, and indents lines according to the box
    structure.
 
+   For a gentle introduction to the basics of prety-printing using
+   [Format], read the FAQ at [http://caml.inria.fr/FAQ/format-eng.html]. 
+
    Warning: the material output by the following functions is delayed
    in the pretty-printer queue in order to compute the proper line
    breaking. Hence, you should not mix calls to the printing functions
@@ -162,6 +165,12 @@ val set_margin : int -> unit;;
    Nothing happens if [d] is smaller than 2 or
    bigger than 999999999. *)
 
+val set_margin_to_max : unit -> unit;;
+
+(** [set_margin_to_max ()] sets the value of the right margin to the
+   maximum possible value compatible with the various invariants of
+   the pretty printer. *)
+
 val get_margin : unit -> int;;
 (** Returns the position of the right margin. *)
 
@@ -520,6 +529,7 @@ val pp_set_mark_tags : formatter -> bool -> unit;;
 val pp_get_print_tags : formatter -> unit -> bool;;
 val pp_get_mark_tags : formatter -> unit -> bool;;
 val pp_set_margin : formatter -> int -> unit;;
+val pp_set_margin_to_max : formatter -> unit -> unit;;
 val pp_get_margin : formatter -> unit -> int;;
 val pp_set_max_indent : formatter -> int -> unit;;
 val pp_get_max_indent : formatter -> unit -> int;;
@@ -584,9 +594,11 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;;
      [nspaces] and [offset] parameters of the break may be
      optionally specified with the following syntax: 
      the [<] character, followed by an integer [nspaces] value,
-     then an integer offset, and a closing [>] character. 
+     then an integer offset, and a closing [>] character.
+     If no parameters are provided, the good break defaults to a
+     space.
    - [@?]: flush the pretty printer as with [print_flush ()].
-     This is equivalent to the conversion [%$].
+     This is equivalent to the conversion [%!].
    - [@.]: flush the pretty printer and output a new line, as with
      [print_newline ()].
    - [@<n>]: print the following item as if it were of length [n].
@@ -643,6 +655,14 @@ val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a;;
    pretty-printer queue would result in unexpected and badly formatted
    output. *)
 
-val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
+val kfprintf : (formatter -> 'a) -> formatter ->
+              ('b, formatter, unit, 'a) format4 -> 'b;;
+(** Same as [fprintf] above, but instead of returning immediately,
+   passes the formatter to its first argument at the end of printing. *)
+
+val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
 (** Same as [sprintf] above, but instead of returning the string,
    passes it to the first argument. *)
+
+val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
+(** A deprecated synonym for ksprintf. *)
diff --git a/stdlib/gc.ml b/stdlib/gc.ml
index 1f34a06c..fac7ab38 100644
--- a/stdlib/gc.ml
+++ b/stdlib/gc.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: gc.ml,v 1.17 2003/08/07 14:17:59 doligez Exp $ *)
+(* $Id: gc.ml,v 1.20 2004/06/14 13:27:36 doligez Exp $ *)
 
 type stat = {
   minor_words : float;
@@ -40,15 +40,16 @@ type control = {
   mutable stack_limit : int;
 };;
 
-external stat : unit -> stat = "gc_stat";;
-external counters : unit -> (float * float * float) = "gc_counters";;
-external get : unit -> control = "gc_get";;
-external set : control -> unit = "gc_set";;
-external minor : unit -> unit = "gc_minor";;
-external major_slice : int -> int = "gc_major_slice";;
-external major : unit -> unit = "gc_major";;
-external full_major : unit -> unit = "gc_full_major";;
-external compact : unit -> unit = "gc_compaction";;
+external stat : unit -> stat = "caml_gc_stat";;
+external quick_stat : unit -> stat = "caml_gc_quick_stat";;
+external counters : unit -> (float * float * float) = "caml_gc_counters";;
+external get : unit -> control = "caml_gc_get";;
+external set : control -> unit = "caml_gc_set";;
+external minor : unit -> unit = "caml_gc_minor";;
+external major_slice : int -> int = "caml_gc_major_slice";;
+external major : unit -> unit = "caml_gc_major";;
+external full_major : unit -> unit = "caml_gc_full_major";;
+external compact : unit -> unit = "caml_gc_compaction";;
 
 open Printf;;
 
@@ -76,7 +77,8 @@ let allocated_bytes () =
   (mi +. ma -. pro) *. float_of_int (Sys.word_size / 8)
 ;;
 
-external finalise : ('a -> unit) -> 'a -> unit = "final_register";;
+external finalise : ('a -> unit) -> 'a -> unit = "caml_final_register";;
+external finalise_release : unit -> unit = "caml_final_release";;
 
 
 type alarm = bool ref;;
diff --git a/stdlib/gc.mli b/stdlib/gc.mli
index c63e1414..7b309bf8 100644
--- a/stdlib/gc.mli
+++ b/stdlib/gc.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: gc.mli,v 1.37 2002/08/01 14:14:10 doligez Exp $ *)
+(* $Id: gc.mli,v 1.40 2004/06/14 13:27:36 doligez Exp $ *)
 
 (** Memory management control and statistics; finalised values. *)
 
@@ -129,38 +129,45 @@ type control =
 }
 (** The GC parameters are given as a [control] record. *)
 
-external stat : unit -> stat = "gc_stat"
+external stat : unit -> stat = "caml_gc_stat"
 (** Return the current values of the memory management counters in a
-   [stat] record. *)
+   [stat] record.  This function examines every heap block to get the
+   statistics. *)
 
-external counters : unit -> float * float * float = "gc_counters"
-(** Return [(minor_words, promoted_words, major_words)].  Much faster
-   than [stat]. *)
+external quick_stat : unit -> stat = "caml_gc_quick_stat"
+(** Same as [stat] except that [live_words], [live_blocks], [free_words],
+    [free_blocks], [largest_free], and [fragments] are set to 0.  This
+    function is much faster than [stat] because it does not need to go
+    through the heap. *)
 
-external get : unit -> control = "gc_get"
+external counters : unit -> float * float * float = "caml_gc_counters"
+(** Return [(minor_words, promoted_words, major_words)].  This function
+    is as fast at [quick_stat]. *)
+
+external get : unit -> control = "caml_gc_get"
 (** Return the current values of the GC parameters in a [control] record. *)
 
-external set : control -> unit = "gc_set"
+external set : control -> unit = "caml_gc_set"
 (** [set r] changes the GC parameters according to the [control] record [r].
    The normal usage is: [Gc.set { (Gc.get()) with Gc.verbose = 0x00d }] *)
 
-external minor : unit -> unit = "gc_minor"
+external minor : unit -> unit = "caml_gc_minor"
 (** Trigger a minor collection. *)
 
-external major_slice : int -> int = "gc_major_slice";;
+external major_slice : int -> int = "caml_gc_major_slice";;
 (** Do a minor collection and a slice of major collection.  The argument
     is the size of the slice, 0 to use the automatically-computed
     slice size.  In all cases, the result is the computed slice size. *)
 
-external major : unit -> unit = "gc_major"
+external major : unit -> unit = "caml_gc_major"
 (** Do a minor collection and finish the current major collection cycle. *)
 
-external full_major : unit -> unit = "gc_full_major"
+external full_major : unit -> unit = "caml_gc_full_major"
 (** Do a minor collection, finish the current major collection cycle,
    and perform a complete new cycle.  This will collect all currently
    unreachable blocks. *)
 
-external compact : unit -> unit = "gc_compaction"
+external compact : unit -> unit = "caml_gc_compaction"
 (** Perform a full major collection and compact the heap.  Note that heap
    compaction is a lengthy operation. *)
 
@@ -181,14 +188,15 @@ val finalise : ('a -> unit) -> 'a -> unit
    be registered for the same value, or even several instances of the
    same function.  Each instance will be called once (or never,
    if the program terminates before [v] becomes unreachable).
-   
-  
-   A number of pitfalls are associated with finalised values:
-   finalisation functions are called asynchronously, sometimes
-   even during the execution of other finalisation functions.
-   In a multithreaded program, finalisation functions are called
-   from any thread, thus they must not acquire any mutex.
 
+   The GC will call the finalisation functions in the order of
+   deallocation.  When several values become unreachable at the
+   same time (i.e. during the same GC cycle), the finalisation
+   functions will be called in the reverse order of the corresponding
+   calls to [finalise].  If [finalise] is called in the same order
+   as the values are allocated, that means each value is finalised
+   before the values it depends upon.  Of course, this becomes
+   false if additional dependencies are introduced by assignments.
 
    Anything reachable from the closure of finalisation functions
    is considered reachable, so the following code will not work
@@ -225,10 +233,14 @@ val finalise : ('a -> unit) -> 'a -> unit
    
    The results of calling {!String.make}, {!String.create},
    {!Array.make}, and {!Pervasives.ref} are guaranteed to be
-   heap-allocated and non-constant
-   except when the length argument is [0].
+   heap-allocated and non-constant except when the length argument is [0].
 *)
 
+val finalise_release : unit -> unit;;
+(** A finalisation function may call [finalise_release] to tell the
+    GC that it can launch the next finalisation function without waiting
+    for the current one to return. *)
+
 type alarm
 (** An alarm is a piece of data that calls a user function at the end of
    each major GC cycle.  The following functions are provided to create
diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
index 54637133..a440b019 100644
--- a/stdlib/hashtbl.ml
+++ b/stdlib/hashtbl.ml
@@ -11,11 +11,11 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: hashtbl.ml,v 1.23 2002/01/23 17:52:46 doligez Exp $ *)
+(* $Id: hashtbl.ml,v 1.26 2004/03/23 12:37:19 starynke Exp $ *)
 
 (* Hash tables *)
 
-external hash_param : int -> int -> 'a -> int = "hash_univ_param" "noalloc"
+external hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc"
 
 let hash x = hash_param 10 100 x
 
@@ -44,6 +44,8 @@ let copy h =
   { size = h.size;
     data = Array.copy h.data }
 
+let length h = h.size
+
 let resize hashfun tbl =
   let odata = tbl.data in
   let osize = Array.length odata in
@@ -74,7 +76,7 @@ let remove h key =
       Empty ->
         Empty
     | Cons(k, i, next) ->
-        if k = key
+        if compare k key = 0
         then begin h.size <- pred h.size; next end
         else Cons(k, i, remove_bucket next) in
   let i = (hash key) mod (Array.length h.data) in
@@ -84,28 +86,30 @@ let rec find_rec key = function
     Empty ->
       raise Not_found
   | Cons(k, d, rest) ->
-      if key = k then d else find_rec key rest
+      if compare key k = 0 then d else find_rec key rest
 
 let find h key =
   match h.data.((hash key) mod (Array.length h.data)) with
     Empty -> raise Not_found
   | Cons(k1, d1, rest1) ->
-      if key = k1 then d1 else
+      if compare key k1 = 0 then d1 else
       match rest1 with
         Empty -> raise Not_found
       | Cons(k2, d2, rest2) ->
-          if key = k2 then d2 else
+          if compare key k2 = 0 then d2 else
           match rest2 with
             Empty -> raise Not_found
           | Cons(k3, d3, rest3) ->
-              if key = k3 then d3 else find_rec key rest3
+              if compare key k3 = 0 then d3 else find_rec key rest3
 
 let find_all h key =
   let rec find_in_bucket = function
     Empty ->
       []
   | Cons(k, d, rest) ->
-      if k = key then d :: find_in_bucket rest else find_in_bucket rest in
+      if compare k key = 0
+      then d :: find_in_bucket rest
+      else find_in_bucket rest in
   find_in_bucket h.data.((hash key) mod (Array.length h.data))
 
 let replace h key info =
@@ -113,7 +117,7 @@ let replace h key info =
       Empty ->
         raise Not_found
     | Cons(k, i, next) ->
-        if k = key
+        if compare k key = 0
         then Cons(k, info, next)
         else Cons(k, i, replace_bucket next) in
   let i = (hash key) mod (Array.length h.data) in
@@ -130,7 +134,7 @@ let mem h key =
   | Empty ->
       false
   | Cons(k, d, rest) ->
-      k = key || mem_in_bucket rest in
+      compare k key = 0 || mem_in_bucket rest in
   mem_in_bucket h.data.((hash key) mod (Array.length h.data))
 
 let iter f h =
@@ -182,6 +186,7 @@ module type S =
     val mem : 'a t -> key -> bool
     val iter: (key -> 'a -> unit) -> 'a t -> unit
     val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val length: 'a t -> int
   end
 
 module Make(H: HashedType): (S with type key = H.t) =
@@ -270,4 +275,7 @@ module Make(H: HashedType): (S with type key = H.t) =
 
     let iter = iter
     let fold = fold
+    let length = length
   end
+
+(* eof $Id: hashtbl.ml,v 1.26 2004/03/23 12:37:19 starynke Exp $ *)
diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
index 2e0fc63e..d07a647f 100644
--- a/stdlib/hashtbl.mli
+++ b/stdlib/hashtbl.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: hashtbl.mli,v 1.32 2003/06/23 13:19:35 xleroy Exp $ *)
+(* $Id: hashtbl.mli,v 1.35 2004/03/23 12:37:06 starynke Exp $ *)
 
 (** Hash tables and hash functions.
 
@@ -35,6 +35,7 @@ val create : int -> ('a, 'b) t
 val clear : ('a, 'b) t -> unit
 (** Empty a hash table. *)
 
+
 val add : ('a, 'b) t -> 'a -> 'b -> unit
 (** [Hashtbl.add tbl x y] adds a binding of [x] to [y] in table [tbl].
    Previous bindings for [x] are not removed, but simply
@@ -91,6 +92,12 @@ val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
    the most recent binding is passed first. *)
 
 
+val length : ('a, 'b) t -> int
+(** [Hashtbl.length tbl] returns the number of bindings in [tbl]. 
+   Multiple bindings are counted multiply, so [Hashtbl.length] 
+   gives the number of times [Hashtbl.iter] calls it first argument. *)
+
+
 (** {6 Functorial interface} *)
 
 
@@ -106,7 +113,10 @@ module type HashedType =
           as computed by [hash].
           Examples: suitable ([equal], [hash]) pairs for arbitrary key
           types include
-          ([(=)], {!Hashtbl.hash}) for comparing objects by structure, and
+          ([(=)], {!Hashtbl.hash}) for comparing objects by structure,
+          ([(fun x y -> compare x y = 0)], {!Hashtbl.hash})
+          for comparing objects by structure and handling {!Pervasives.nan}
+          correctly, and
           ([(==)], {!Hashtbl.hash}) for comparing objects by addresses
           (e.g. for mutable or cyclic keys). *)
    end
@@ -127,6 +137,7 @@ module type S =
     val mem : 'a t -> key -> bool
     val iter : (key -> 'a -> unit) -> 'a t -> unit
     val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val length : 'a t -> int
   end
 (** The output signature of the functor {!Hashtbl.Make}. *)
 
@@ -147,11 +158,11 @@ module Make (H : HashedType) : S with type key = H.t
 val hash : 'a -> int
 (** [Hashtbl.hash x] associates a positive integer to any value of
    any type. It is guaranteed that
-   if [x = y], then [hash x = hash y]. 
+   if [x = y] or [Pervasives.compare x y = 0], then [hash x = hash y]. 
    Moreover, [hash] always terminates, even on cyclic
    structures. *)
 
-external hash_param : int -> int -> 'a -> int = "hash_univ_param" "noalloc"
+external hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc"
 (** [Hashtbl.hash_param n m x] computes a hash value for [x], with the
    same properties as for [hash]. The two extra parameters [n] and
    [m] give more precise control over hashing. Hashing performs a
diff --git a/stdlib/int32.ml b/stdlib/int32.ml
index 086143c4..c0364854 100644
--- a/stdlib/int32.ml
+++ b/stdlib/int32.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: int32.ml,v 1.7 2003/04/25 12:27:30 xleroy Exp $ *)
+(* $Id: int32.ml,v 1.9 2004/01/01 16:42:40 doligez Exp $ *)
 
 (* Module [Int32]: 32-bit integers *)
 
@@ -29,8 +29,10 @@ external shift_right : int32 -> int -> int32 = "%int32_asr"
 external shift_right_logical : int32 -> int -> int32 = "%int32_lsr"
 external of_int : int -> int32 = "%int32_of_int"
 external to_int : int32 -> int = "%int32_to_int"
-external of_float : float -> int32 = "int32_of_float"
-external to_float : int32 -> float = "int32_to_float"
+external of_float : float -> int32 = "caml_int32_of_float"
+external to_float : int32 -> float = "caml_int32_to_float"
+external bits_of_float : float -> int32 = "caml_int32_bits_of_float"
+external float_of_bits : int32 -> float = "caml_int32_float_of_bits"
 
 let zero = 0l
 let one = 1l
@@ -42,10 +44,10 @@ let min_int = 0x80000000l
 let max_int = 0x7FFFFFFFl
 let lognot n = logxor n (-1l)
 
-external format : string -> int32 -> string = "int32_format"
+external format : string -> int32 -> string = "caml_int32_format"
 let to_string n = format "%d" n
 
-external of_string : string -> int32 = "int32_of_string"
+external of_string : string -> int32 = "caml_int32_of_string"
 
 type t = int32
 
diff --git a/stdlib/int32.mli b/stdlib/int32.mli
index 6ae18977..da70cde5 100644
--- a/stdlib/int32.mli
+++ b/stdlib/int32.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: int32.mli,v 1.13 2003/09/09 09:18:58 xleroy Exp $ *)
+(* $Id: int32.mli,v 1.16 2004/01/01 16:42:40 doligez Exp $ *)
 
 (** 32-bit integers.
 
@@ -113,26 +113,39 @@ external to_int : int32 -> int = "%int32_to_int"
    during the conversion.  On 64-bit platforms, the conversion
    is exact. *)
 
-external of_float : float -> int32 = "int32_of_float"
+external of_float : float -> int32 = "caml_int32_of_float"
 (** Convert the given floating-point number to a 32-bit integer,
    discarding the fractional part (truncate towards 0).
    The result of the conversion is undefined if, after truncation,
    the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *)
 
-external to_float : int32 -> float = "int32_to_float"
+external to_float : int32 -> float = "caml_int32_to_float"
 (** Convert the given 32-bit integer to a floating-point number. *)
 
-external of_string : string -> int32 = "int32_of_string"
+external of_string : string -> int32 = "caml_int32_of_string"
 (** Convert the given string to a 32-bit integer.
    The string is read in decimal (by default) or in hexadecimal,
    octal or binary if the string begins with [0x], [0o] or [0b]
    respectively.
    Raise [Failure "int_of_string"] if the given string is not
-   a valid representation of an integer. *)
+   a valid representation of an integer, or if the integer represented
+   exceeds the range of integers representable in type [int32]. *)
 
 val to_string : int32 -> string
 (** Return the string representation of its argument, in signed decimal. *)
 
+external bits_of_float : float -> int32 = "caml_int32_bits_of_float"
+(** Return the internal representation of the given float according
+   to the IEEE 754 floating-point ``single format'' bit layout.
+   Bit 31 of the result represents the sign of the float;
+   bits 30 to 23 represent the (biased) exponent; bits 22 to 0
+   represent the mantissa. *)
+
+external float_of_bits : int32 -> float = "caml_int32_float_of_bits"
+(** Return the floating-point number whose internal representation,
+   according to the IEEE 754 floating-point ``single format'' bit layout,
+   is the given [int32]. *)
+
 type t = int32
 (** An alias for the type of 32-bit integers. *)
 
@@ -146,7 +159,7 @@ val compare: t -> t -> int
 
 (** {6 Deprecated functions} *)
 
-external format : string -> int32 -> string = "int32_format"
+external format : string -> int32 -> string = "caml_int32_format"
 (** [Int32.format fmt n] return the string representation of the
    32-bit integer [n] in the format specified by [fmt].
    [fmt] is a [Printf]-style format consisting of exactly
diff --git a/stdlib/int64.ml b/stdlib/int64.ml
index 4d6e67df..11b6ffac 100644
--- a/stdlib/int64.ml
+++ b/stdlib/int64.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: int64.ml,v 1.10 2003/04/25 12:27:31 xleroy Exp $ *)
+(* $Id: int64.ml,v 1.11 2004/01/01 16:42:40 doligez Exp $ *)
 
 (* Module [Int64]: 64-bit integers *)
 
@@ -29,8 +29,8 @@ external shift_right : int64 -> int -> int64 = "%int64_asr"
 external shift_right_logical : int64 -> int -> int64 = "%int64_lsr"
 external of_int : int -> int64 = "%int64_of_int"
 external to_int : int64 -> int = "%int64_to_int"
-external of_float : float -> int64 = "int64_of_float"
-external to_float : int64 -> float = "int64_to_float"
+external of_float : float -> int64 = "caml_int64_of_float"
+external to_float : int64 -> float = "caml_int64_to_float"
 external of_int32 : int32 -> int64 = "%int64_of_int32"
 external to_int32 : int64 -> int32 = "%int64_to_int32"
 external of_nativeint : nativeint -> int64 = "%int64_of_nativeint"
@@ -46,13 +46,13 @@ let min_int = 0x8000000000000000L
 let max_int = 0x7FFFFFFFFFFFFFFFL
 let lognot n = logxor n (-1L)
 
-external format : string -> int64 -> string = "int64_format"
+external format : string -> int64 -> string = "caml_int64_format"
 let to_string n = format "%d" n
 
-external of_string : string -> int64 = "int64_of_string"
+external of_string : string -> int64 = "caml_int64_of_string"
 
-external bits_of_float : float -> int64 = "int64_bits_of_float"
-external float_of_bits : int64 -> float = "int64_float_of_bits"
+external bits_of_float : float -> int64 = "caml_int64_bits_of_float"
+external float_of_bits : int64 -> float = "caml_int64_float_of_bits"
 
 type t = int64
 
diff --git a/stdlib/int64.mli b/stdlib/int64.mli
index dc835ff8..3f8a9fc5 100644
--- a/stdlib/int64.mli
+++ b/stdlib/int64.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: int64.mli,v 1.15 2003/09/09 09:18:58 xleroy Exp $ *)
+(* $Id: int64.mli,v 1.17 2004/01/01 16:42:40 doligez Exp $ *)
 
 (** 64-bit integers.
 
@@ -114,13 +114,13 @@ external to_int : int64 -> int = "%int64_to_int"
    is taken modulo 2{^31}, i.e. the top 33 bits are lost
    during the conversion. *)
 
-external of_float : float -> int64 = "int64_of_float"
+external of_float : float -> int64 = "caml_int64_of_float"
 (** Convert the given floating-point number to a 64-bit integer,
    discarding the fractional part (truncate towards 0).
    The result of the conversion is undefined if, after truncation,
    the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *)
 
-external to_float : int64 -> float = "int64_to_float"
+external to_float : int64 -> float = "caml_int64_to_float"
 (** Convert the given 64-bit integer to a floating-point number. *)
 
 
@@ -144,25 +144,26 @@ external to_nativeint : int64 -> nativeint = "%int64_to_nativeint"
    is taken modulo 2{^32}.  On 64-bit platforms,
    the conversion is exact. *)
 
-external of_string : string -> int64 = "int64_of_string"
+external of_string : string -> int64 = "caml_int64_of_string"
 (** Convert the given string to a 64-bit integer.
    The string is read in decimal (by default) or in hexadecimal,
    octal or binary if the string begins with [0x], [0o] or [0b]
    respectively.
    Raise [Failure "int_of_string"] if the given string is not
-   a valid representation of an integer. *)
+   a valid representation of an integer, or if the integer represented
+   exceeds the range of integers representable in type [int64]. *)
 
 val to_string : int64 -> string
 (** Return the string representation of its argument, in decimal. *)
 
-external bits_of_float : float -> int64 = "int64_bits_of_float"
+external bits_of_float : float -> int64 = "caml_int64_bits_of_float"
 (** Return the internal representation of the given float according
    to the IEEE 754 floating-point ``double format'' bit layout.
    Bit 63 of the result represents the sign of the float;
    bits 62 to 52 represent the (biased) exponent; bits 51 to 0
    represent the mantissa. *)
 
-external float_of_bits : int64 -> float = "int64_float_of_bits"
+external float_of_bits : int64 -> float = "caml_int64_float_of_bits"
 (** Return the floating-point number whose internal representation,
    according to the IEEE 754 floating-point ``double format'' bit layout,
    is the given [int64]. *)
@@ -180,7 +181,7 @@ val compare: t -> t -> int
 
 (** {6 Deprecated functions} *)
 
-external format : string -> int64 -> string = "int64_format"
+external format : string -> int64 -> string = "caml_int64_format"
 (** [Int64.format fmt n] return the string representation of the
    64-bit integer [n] in the format specified by [fmt].
    [fmt] is a {!Printf}-style format consisting of exactly one
diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml
index 20175174..8425db7f 100644
--- a/stdlib/lazy.ml
+++ b/stdlib/lazy.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lazy.ml,v 1.8 2003/01/21 12:57:33 doligez Exp $ *)
+(* $Id: lazy.ml,v 1.11 2004/01/01 16:42:40 doligez Exp $ *)
 
 (* Module [Lazy]: deferred computations *)
 
@@ -30,11 +30,16 @@
       type [unit -> 'a] that computes the value.
    2. A block of size 1 with tag [forward_tag].  Its field is the value
       of type ['a] that was computed.
-   3. Anything else.  This has type ['a] and is the value that was computed.
+   3. Anything else except a float.  This has type ['a] and is the value
+      that was computed.
    Exceptions are stored in format (1).
    The GC will magically change things from (2) to (3) according to its
    fancy.
 
+   We cannot use representation (3) for a [float Lazy.t] because
+   [caml_make_array] assumes that only a [float] value can have tag
+   [Double_tag].
+
    We have to use the built-in type constructor [lazy_t] to
    let the compiler implement the special typing and compilation
    rules for the [lazy] keyword.
@@ -45,21 +50,21 @@ exception Undefined;;
 
 let raise_undefined = Obj.repr (fun () -> raise Undefined);;
 
-external is_forward : Obj.t -> bool = "lazy_is_forward";;
-external follow_forward : Obj.t -> 'a = "lazy_follow_forward";;
+external follow_forward : Obj.t -> 'a = "caml_lazy_follow_forward";;
+external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward";;
 
 let force (l : 'arg t) =
   let x = Obj.repr l in
-  if is_forward x then (follow_forward x : 'arg)
-  else if Obj.is_int x then (Obj.obj x : 'arg)
-  else if Obj.tag x <> Obj.lazy_tag then (Obj.obj x : 'arg)
+  let t = Obj.tag x in
+  if t = Obj.forward_tag then (follow_forward x : 'arg)
+  else if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
   else begin
     let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
     Obj.set_field x 0 raise_undefined;
     try
       let result = closure () in
       Obj.set_field x 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
-      Obj.set_tag x (Obj.forward_tag);
+      Obj.set_tag x Obj.forward_tag;
       result
     with e ->
       Obj.set_field x 0 (Obj.repr (fun () -> raise e));
@@ -69,9 +74,9 @@ let force (l : 'arg t) =
 
 let force_val (l : 'arg t) =
   let x = Obj.repr l in
-  if is_forward x then (follow_forward x : 'arg)
-  else if Obj.is_int x then (Obj.obj x : 'arg)
-  else if Obj.tag x <> Obj.lazy_tag then (Obj.obj x : 'arg)
+  let t = Obj.tag x in
+  if t = Obj.forward_tag then (follow_forward x : 'arg)
+  else if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
   else begin
     let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
     Obj.set_field x 0 raise_undefined;
@@ -88,9 +93,13 @@ let lazy_from_fun (f : unit -> 'arg) =
   (Obj.obj x : 'arg t)
 ;;
 
-let lazy_from_val (v : 'arg) = (Obj.magic v : 'arg t);;
-
-let lazy_is_val (l : 'arg t) =
-  let x = Obj.repr l in
-  is_forward x || Obj.is_int x || Obj.tag x <> Obj.lazy_tag
+let lazy_from_val (v : 'arg) =
+  let t = Obj.tag (Obj.repr v) in
+  if t = Obj.forward_tag || t = Obj.lazy_tag || t = Obj.double_tag then begin
+    make_forward v
+  end else begin
+    (Obj.magic v : 'arg t)
+  end
 ;;
+
+let lazy_is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;;
diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml
index f7e2e843..41e6d5c2 100644
--- a/stdlib/lexing.ml
+++ b/stdlib/lexing.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexing.ml,v 1.22 2003/08/13 15:31:36 doligez Exp $ *)
+(* $Id: lexing.ml,v 1.23 2003/12/31 14:20:39 doligez Exp $ *)
 
 (* The run-time library for lexers generated by camllex *)
 
@@ -57,8 +57,9 @@ type lex_tables =
     lex_check_code : string;
     lex_code: string;}
 
-external c_engine: lex_tables -> int -> lexbuf -> int = "lex_engine"
-external c_new_engine: lex_tables -> int -> lexbuf -> int = "new_lex_engine"
+external c_engine : lex_tables -> int -> lexbuf -> int = "caml_lex_engine"
+external c_new_engine : lex_tables -> int -> lexbuf -> int
+                      = "caml_new_lex_engine"
 
 let engine tbl state buf =
   let result = c_engine tbl state buf in
diff --git a/stdlib/list.ml b/stdlib/list.ml
index 839cb889..06e8f378 100644
--- a/stdlib/list.ml
+++ b/stdlib/list.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: list.ml,v 1.29 2002/06/05 12:12:46 doligez Exp $ *)
+(* $Id: list.ml,v 1.31 2004/01/01 16:42:40 doligez Exp $ *)
 
 (* List operations *)
 
@@ -134,7 +134,7 @@ let rec exists2 p l1 l2 =
 
 let rec mem x = function
     [] -> false
-  | a::l -> a = x || mem x l
+  | a::l -> compare a x = 0 || mem x l
 
 let rec memq x = function
     [] -> false
@@ -142,7 +142,7 @@ let rec memq x = function
 
 let rec assoc x = function
     [] -> raise Not_found
-  | (a,b)::l -> if a = x then b else assoc x l
+  | (a,b)::l -> if compare a x = 0 then b else assoc x l
 
 let rec assq x = function
     [] -> raise Not_found
@@ -150,7 +150,7 @@ let rec assq x = function
 
 let rec mem_assoc x = function
   | [] -> false
-  | (a, b) :: l -> a = x || mem_assoc x l
+  | (a, b) :: l -> compare a x = 0 || mem_assoc x l
 
 let rec mem_assq x = function
   | [] -> false
@@ -158,7 +158,7 @@ let rec mem_assq x = function
 
 let rec remove_assoc x = function
   | [] -> []
-  | (a, b as pair) :: l -> if a = x then l else pair :: remove_assoc x l
+  | (a, b as pair) :: l -> if compare a x = 0 then l else pair :: remove_assoc x l
 
 let rec remove_assq x = function
   | [] -> []
@@ -290,7 +290,7 @@ let fast_sort = stable_sort;;
    Also, there seems to be a bug in this code or in the
    implementation of obj_truncate.
 
-external obj_truncate : 'a array -> int -> unit = "obj_truncate"
+external obj_truncate : 'a array -> int -> unit = "caml_obj_truncate"
 
 let array_to_list_in_place a =
   let l = Array.length a in
diff --git a/stdlib/list.mli b/stdlib/list.mli
index b2fc7e23..5cb6f28f 100644
--- a/stdlib/list.mli
+++ b/stdlib/list.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: list.mli,v 1.43 2003/07/25 21:40:06 doligez Exp $ *)
+(* $Id: list.mli,v 1.44 2003/11/21 16:06:08 xleroy Exp $ *)
 
 (** List operations.
 
@@ -242,8 +242,7 @@ val sort : ('a -> 'a -> int) -> 'a list -> 'a list
    compare as equal, a positive integer if the first is greater,
    and a negative integer if the first is smaller (see Array.sort for
    a complete specification).  For example,
-   {!Pervasives.compare} is a suitable comparison function, provided
-   there are no floating-point NaN values in the data.
+   {!Pervasives.compare} is a suitable comparison function.
    The resulting list is sorted in increasing order.
    [List.sort] is guaranteed to run in constant heap space
    (in addition to the size of the result list) and logarithmic
diff --git a/stdlib/map.ml b/stdlib/map.ml
index df34d917..76c479c0 100644
--- a/stdlib/map.ml
+++ b/stdlib/map.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: map.ml,v 1.14 2003/06/23 07:28:54 xleroy Exp $ *)
+(* $Id: map.ml,v 1.15 2004/04/23 10:01:33 xleroy Exp $ *)
 
 module type OrderedType =
   sig
@@ -24,6 +24,7 @@ module type S =
     type key
     type +'a t
     val empty: 'a t
+    val is_empty: 'a t -> bool
     val add: key -> 'a -> 'a t -> 'a t
     val find: key -> 'a t -> 'a
     val remove: key -> 'a t -> 'a t
@@ -32,6 +33,8 @@ module type S =
     val map: ('a -> 'b) -> 'a t -> 'b t
     val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
     val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
   end
 
 module Make(Ord: OrderedType) = struct
@@ -42,8 +45,6 @@ module Make(Ord: OrderedType) = struct
         Empty
       | Node of 'a t * key * 'a * 'a t * int
 
-    let empty = Empty
-
     let height = function
         Empty -> 0
       | Node(_,_,_,_,h) -> h
@@ -82,6 +83,10 @@ module Make(Ord: OrderedType) = struct
       end else
         Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
 
+    let empty = Empty
+
+    let is_empty = function Empty -> true | _ -> false
+
     let rec add x data = function
         Empty ->
           Node(Empty, x, data, Empty, 1)
@@ -158,4 +163,36 @@ module Make(Ord: OrderedType) = struct
       | Node(l, v, d, r, _) ->
           fold f l (f v d (fold f r accu))
 
+    type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
+
+    let rec cons_enum m e =
+      match m with
+        Empty -> e
+      | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
+
+    let compare cmp m1 m2 =
+      let rec compare_aux e1 e2 =
+          match (e1, e2) with
+          (End, End) -> 0
+        | (End, _)  -> -1
+        | (_, End) -> 1
+        | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+            let c = Ord.compare v1 v2 in
+            if c <> 0 then c else
+            let c = cmp d1 d2 in
+            if c <> 0 then c else
+            compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
+      in compare_aux (cons_enum m1 End) (cons_enum m2 End)
+
+    let equal cmp m1 m2 =
+      let rec equal_aux e1 e2 =
+          match (e1, e2) with
+          (End, End) -> true
+        | (End, _)  -> false
+        | (_, End) -> false
+        | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+            Ord.compare v1 v2 = 0 && cmp d1 d2 &&
+            equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
+      in equal_aux (cons_enum m1 End) (cons_enum m2 End)
+
 end
diff --git a/stdlib/map.mli b/stdlib/map.mli
index 0c749922..07ef3ebe 100644
--- a/stdlib/map.mli
+++ b/stdlib/map.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: map.mli,v 1.28 2001/12/10 12:33:54 xleroy Exp $ *)
+(* $Id: map.mli,v 1.32 2004/04/23 10:01:33 xleroy Exp $ *)
 
 (** Association tables over ordered types.
 
@@ -33,8 +33,8 @@ module type OrderedType =
           [f e1 e2] is zero if the keys [e1] and [e2] are equal,
           [f e1 e2] is strictly negative if [e1] is smaller than [e2],
           and [f e1 e2] is strictly positive if [e1] is greater than [e2].
-          Example: a suitable ordering function is
-          the generic structural comparison function {!Pervasives.compare}. *)
+          Example: a suitable ordering function is the generic structural
+          comparison function {!Pervasives.compare}. *)
   end
 (** Input signature of the functor {!Map.Make}. *)
 
@@ -49,6 +49,9 @@ module type S =
     val empty: 'a t
     (** The empty map. *)
 
+    val is_empty: 'a t -> bool
+    (** Test whether a map is empty or not. *)
+
     val add: key -> 'a -> 'a t -> 'a t
     (** [add x y m] returns a map containing the same bindings as
        [m], plus a binding of [x] to [y]. If [x] was already bound
@@ -69,16 +72,17 @@ module type S =
     val iter: (key -> 'a -> unit) -> 'a t -> unit
     (** [iter f m] applies [f] to all bindings in map [m].
        [f] receives the key as first argument, and the associated value
-       as second argument. The order in which the bindings are passed to
-       [f] is unspecified. Only current bindings are presented to [f]:
+       as second argument.  The bindings are passed to [f] in increasing
+       order with respect to the ordering over the type of the keys.
+       Only current bindings are presented to [f]:
        bindings hidden by more recent bindings are not passed to [f]. *)
 
     val map: ('a -> 'b) -> 'a t -> 'b t
     (** [map f m] returns a map with same domain as [m], where the
        associated value [a] of all bindings of [m] has been
        replaced by the result of the application of [f] to [a].
-       The order in which the associated values are passed to [f]
-       is unspecified. *)
+       The bindings are passed to [f] in increasing order
+       with respect to the ordering over the type of the keys. *)
 
     val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
     (** Same as {!Map.S.map}, but the function receives as arguments both the
@@ -86,10 +90,19 @@ module type S =
 
     val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
     (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
-       where [k1 ... kN] are the keys of all bindings in [m],
-       and [d1 ... dN] are the associated data.
-       The order in which the bindings are presented to [f] is
-       unspecified. *)
+       where [k1 ... kN] are the keys of all bindings in [m]
+       (in increasing order), and [d1 ... dN] are the associated data. *)
+
+    val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    (** Total ordering between maps.  The first argument is a total ordering
+        used to compare data associated with equal keys in the two maps. *)
+
+    val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are
+       equal, that is, contain equal keys and associate them with
+       equal data.  [cmp] is the equality predicate used to compare
+       the data associated with the keys. *)
+
   end
 (** Output signature of the functor {!Map.Make}. *)
 
diff --git a/stdlib/marshal.ml b/stdlib/marshal.ml
index 783349fb..428add2e 100644
--- a/stdlib/marshal.ml
+++ b/stdlib/marshal.ml
@@ -11,28 +11,29 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: marshal.ml,v 1.7 2002/07/12 09:47:54 xleroy Exp $ *)
+(* $Id: marshal.ml,v 1.8 2004/01/01 16:42:40 doligez Exp $ *)
 
 type extern_flags =
     No_sharing
   | Closures
 
 external to_channel: out_channel -> 'a -> extern_flags list -> unit
-    = "output_value"
+    = "caml_output_value"
 external to_string: 'a -> extern_flags list -> string
-    = "output_value_to_string"
+    = "caml_output_value_to_string"
 external to_buffer_unsafe:
       string -> int -> int -> 'a -> extern_flags list -> int
-    = "output_value_to_buffer"
+    = "caml_output_value_to_buffer"
 
 let to_buffer buff ofs len v flags =
   if ofs < 0 || len < 0 || ofs > String.length buff - len
   then invalid_arg "Marshal.to_buffer: substring out of bounds"
   else to_buffer_unsafe buff ofs len v flags
 
-external from_channel: in_channel -> 'a = "input_value"
-external from_string_unsafe: string -> int -> 'a = "input_value_from_string"
-external data_size_unsafe: string -> int -> int = "marshal_data_size"
+external from_channel: in_channel -> 'a = "caml_input_value"
+external from_string_unsafe: string -> int -> 'a
+                           = "caml_input_value_from_string"
+external data_size_unsafe: string -> int -> int = "caml_marshal_data_size"
 
 let header_size = 20
 let data_size buff ofs =
diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli
index f7dddead..2ba28639 100644
--- a/stdlib/marshal.mli
+++ b/stdlib/marshal.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: marshal.mli,v 1.12 2001/12/07 13:40:55 xleroy Exp $ *)
+(* $Id: marshal.mli,v 1.13 2004/01/01 16:42:40 doligez Exp $ *)
 
 (** Marshaling of data structures.
 
@@ -80,7 +80,7 @@ val to_channel : out_channel -> 'a -> extern_flags list -> unit
    transmitted along with the code position.) *)
 
 external to_string :
-  'a -> extern_flags list -> string = "output_value_to_string"
+  'a -> extern_flags list -> string = "caml_output_value_to_string"
 (** [Marshal.to_string v flags] returns a string containing
    the representation of [v] as a sequence of bytes.
    The [flags] argument has the same meaning as for
diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
index 3de0155c..fa6b3550 100644
--- a/stdlib/moreLabels.mli
+++ b/stdlib/moreLabels.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: moreLabels.mli,v 1.8 2001/12/07 13:40:55 xleroy Exp $ *)
+(* $Id: moreLabels.mli,v 1.12 2004/04/23 10:01:34 xleroy Exp $ *)
 
 (** Extra labeled libraries.
 
@@ -38,6 +38,7 @@ module Hashtbl : sig
   val fold :
       f:(key:'a -> data:'b -> 'c -> 'c) ->
         ('a, 'b) t -> init:'c -> 'c
+  val length : ('a, 'b) t -> int
   module type HashedType = Hashtbl.HashedType
   module type S =
     sig
@@ -56,11 +57,12 @@ module Hashtbl : sig
       val fold :
           f:(key:key -> data:'a -> 'b -> 'b) ->
           'a t -> init:'b -> 'b
+      val length : 'a t -> int
     end
   module Make : functor (H : HashedType) -> S with type key = H.t
   val hash : 'a -> int
   external hash_param : int -> int -> 'a -> int
-      = "hash_univ_param" "noalloc"
+      = "caml_hash_univ_param" "noalloc"
 end
 
 module Map : sig
@@ -70,6 +72,7 @@ module Map : sig
       type key
       and (+'a) t
       val empty : 'a t
+      val is_empty: 'a t -> bool
       val add : key:key -> data:'a -> 'a t -> 'a t
       val find : key -> 'a t -> 'a
       val remove : key -> 'a t -> 'a t
@@ -80,7 +83,9 @@ module Map : sig
       val fold :
           f:(key:key -> data:'a -> 'b -> 'b) ->
           'a t -> init:'b -> 'b
-    end
+      val compare: cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int
+      val equal: cmp:('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+  end
   module Make : functor (Ord : OrderedType) -> S with type key = Ord.t
 end
 
@@ -113,6 +118,7 @@ module Set : sig
       val min_elt : t -> elt
       val max_elt : t -> elt
       val choose : t -> elt
+      val split: elt -> t -> t * bool * t
     end
   module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t
 end
diff --git a/stdlib/nativeint.ml b/stdlib/nativeint.ml
index df4daf7b..02c1ecf1 100644
--- a/stdlib/nativeint.ml
+++ b/stdlib/nativeint.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: nativeint.ml,v 1.9 2003/04/25 12:27:31 xleroy Exp $ *)
+(* $Id: nativeint.ml,v 1.10 2004/01/01 16:42:40 doligez Exp $ *)
 
 (* Module [Nativeint]: processor-native integers *)
 
@@ -29,8 +29,8 @@ external shift_right: nativeint -> int -> nativeint = "%nativeint_asr"
 external shift_right_logical: nativeint -> int -> nativeint = "%nativeint_lsr"
 external of_int: int -> nativeint = "%nativeint_of_int"
 external to_int: nativeint -> int = "%nativeint_to_int"
-external of_float : float -> nativeint = "nativeint_of_float"
-external to_float : nativeint -> float = "nativeint_to_float"
+external of_float : float -> nativeint = "caml_nativeint_of_float"
+external to_float : nativeint -> float = "caml_nativeint_to_float"
 external of_int32: int32 -> nativeint = "%nativeint_of_int32"
 external to_int32: nativeint -> int32 = "%nativeint_to_int32"
 
@@ -45,10 +45,10 @@ let min_int = shift_left 1n (size - 1)
 let max_int = sub min_int 1n
 let lognot n = logxor n (-1n)
 
-external format : string -> nativeint -> string = "nativeint_format"
+external format : string -> nativeint -> string = "caml_nativeint_format"
 let to_string n = format "%d" n
 
-external of_string: string -> nativeint = "nativeint_of_string"
+external of_string: string -> nativeint = "caml_nativeint_of_string"
 
 type t = nativeint
 
diff --git a/stdlib/nativeint.mli b/stdlib/nativeint.mli
index 83cb7242..543ac4a0 100644
--- a/stdlib/nativeint.mli
+++ b/stdlib/nativeint.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: nativeint.mli,v 1.15 2003/09/09 09:18:58 xleroy Exp $ *)
+(* $Id: nativeint.mli,v 1.17 2004/01/01 16:42:40 doligez Exp $ *)
 
 (** Processor-native integers.
 
@@ -130,14 +130,14 @@ external to_int : nativeint -> int = "%nativeint_to_int"
    integer (type [int]).  The high-order bit is lost during
    the conversion. *)
 
-external of_float : float -> nativeint = "nativeint_of_float"
+external of_float : float -> nativeint = "caml_nativeint_of_float"
 (** Convert the given floating-point number to a native integer,
    discarding the fractional part (truncate towards 0).
    The result of the conversion is undefined if, after truncation,
    the number is outside the range
    \[{!Nativeint.min_int}, {!Nativeint.max_int}\]. *)
        
-external to_float : nativeint -> float = "nativeint_to_float"
+external to_float : nativeint -> float = "caml_nativeint_to_float"
 (** Convert the given native integer to a floating-point number. *)
 
 external of_int32 : int32 -> nativeint = "%nativeint_of_int32"
@@ -151,13 +151,14 @@ external to_int32 : nativeint -> int32 = "%nativeint_to_int32"
    i.e. the top 32 bits are lost.  On 32-bit platforms,
    the conversion is exact. *)
 
-external of_string : string -> nativeint = "nativeint_of_string"
+external of_string : string -> nativeint = "caml_nativeint_of_string"
 (** Convert the given string to a native integer.
    The string is read in decimal (by default) or in hexadecimal,
    octal or binary if the string begins with [0x], [0o] or [0b]
    respectively.
    Raise [Failure "int_of_string"] if the given string is not
-   a valid representation of an integer. *)
+   a valid representation of an integer, or if the integer represented
+   exceeds the range of integers representable in type [nativeint]. *)
 
 val to_string : nativeint -> string
 (** Return the string representation of its argument, in decimal. *)
@@ -175,7 +176,7 @@ val compare: t -> t -> int
 
 (** {6 Deprecated functions} *)
 
-external format : string -> nativeint -> string = "nativeint_format"
+external format : string -> nativeint -> string = "caml_nativeint_format"
 (** [Nativeint.format fmt n] return the string representation of the
    native integer [n] in the format specified by [fmt].
    [fmt] is a [Printf]-style format consisting of exactly
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index 91d1dbe2..465642e2 100644
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: obj.ml,v 1.21 2002/01/23 17:51:41 doligez Exp $ *)
+(* $Id: obj.ml,v 1.23 2004/01/01 16:42:40 doligez Exp $ *)
 
 (* Operations on internal representations of values *)
 
@@ -20,16 +20,16 @@ type t
 external repr : 'a -> t = "%identity"
 external obj : t -> 'a = "%identity"
 external magic : 'a -> 'b = "%identity"
-external is_block : t -> bool = "obj_is_block"
+external is_block : t -> bool = "caml_obj_is_block"
 external is_int : t -> bool = "%obj_is_int"
-external tag : t -> int = "obj_tag"
-external set_tag : t -> int -> unit = "obj_set_tag"
+external tag : t -> int = "caml_obj_tag"
+external set_tag : t -> int -> unit = "caml_obj_set_tag"
 external size : t -> int = "%obj_size"
 external field : t -> int -> t = "%obj_field"
 external set_field : t -> int -> t -> unit = "%obj_set_field"
-external new_block : int -> int -> t = "obj_block"
-external dup : t -> t = "obj_dup"
-external truncate : t -> int -> unit = "obj_truncate"
+external new_block : int -> int -> t = "caml_obj_block"
+external dup : t -> t = "caml_obj_dup"
+external truncate : t -> int -> unit = "caml_obj_truncate"
 
 let marshal (obj : t) =
   Marshal.to_string obj []
@@ -50,3 +50,7 @@ let double_tag = 253
 let double_array_tag = 254
 let custom_tag = 255
 let final_tag = custom_tag
+
+
+let int_tag = 1000
+let out_of_heap_tag = 1001
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index 2ff36176..26de175f 100644
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: obj.mli,v 1.25 2002/01/23 17:51:41 doligez Exp $ *)
+(* $Id: obj.mli,v 1.27 2004/01/01 16:42:40 doligez Exp $ *)
 
 (** Operations on internal representations of values.
 
@@ -23,16 +23,16 @@ type t
 external repr : 'a -> t = "%identity"
 external obj : t -> 'a = "%identity"
 external magic : 'a -> 'b = "%identity"
-external is_block : t -> bool = "obj_is_block"
+external is_block : t -> bool = "caml_obj_is_block"
 external is_int : t -> bool = "%obj_is_int"
-external tag : t -> int = "obj_tag"
-external set_tag : t -> int -> unit = "obj_set_tag"
+external tag : t -> int = "caml_obj_tag"
+external set_tag : t -> int -> unit = "caml_obj_set_tag"
 external size : t -> int = "%obj_size"
-external truncate : t -> int -> unit = "obj_truncate"
+external truncate : t -> int -> unit = "caml_obj_truncate"
 external field : t -> int -> t = "%obj_field"
 external set_field : t -> int -> t -> unit = "%obj_set_field"
-external new_block : int -> int -> t = "obj_block"
-external dup : t -> t = "obj_dup"
+external new_block : int -> int -> t = "caml_obj_block"
+external dup : t -> t = "caml_obj_dup"
 
 val lazy_tag : int
 val closure_tag : int
@@ -47,6 +47,9 @@ val double_array_tag : int
 val custom_tag : int
 val final_tag : int  (* DEPRECATED *)
 
+val int_tag : int
+val out_of_heap_tag : int
+
 (** The following two functions are deprecated.  Use module {!Marshal}
     instead. *)
 
diff --git a/stdlib/oo.ml b/stdlib/oo.ml
index 72b9b584..33245e3c 100644
--- a/stdlib/oo.ml
+++ b/stdlib/oo.ml
@@ -11,9 +11,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: oo.ml,v 1.26 2002/06/26 09:12:49 xleroy Exp $ *)
+(* $Id: oo.ml,v 1.27 2004/05/26 11:10:52 garrigue Exp $ *)
 
 let copy = CamlinternalOO.copy
 external id : < .. > -> int = "%field1"
-let new_method = CamlinternalOO.new_method
+let new_method = CamlinternalOO.public_method_label
 let public_method_label = CamlinternalOO.public_method_label
diff --git a/stdlib/oo.mli b/stdlib/oo.mli
index f952c5aa..623fe1eb 100644
--- a/stdlib/oo.mli
+++ b/stdlib/oo.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: oo.mli,v 1.27 2002/06/26 09:12:49 xleroy Exp $ *)
+(* $Id: oo.mli,v 1.28 2004/05/26 11:10:52 garrigue Exp $ *)
 
 (** Operations on objects *)
 
@@ -25,5 +25,5 @@ external id : < .. > -> int = "%field1"
 
 (**/**)
 (** For internal use (CamlIDL) *)
-val new_method : string -> CamlinternalOO.label
-val public_method_label : string -> CamlinternalOO.label
+val new_method : string -> CamlinternalOO.tag
+val public_method_label : string -> CamlinternalOO.tag
diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
index 68289d98..4365d72d 100644
--- a/stdlib/parsing.ml
+++ b/stdlib/parsing.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parsing.ml,v 1.17 2003/08/01 23:28:58 doligez Exp $ *)
+(* $Id: parsing.ml,v 1.18 2004/01/01 16:42:40 doligez Exp $ *)
 
 (* The parsing engine *)
 
@@ -76,7 +76,7 @@ type parser_output =
 
 external parse_engine :
     parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output
-    = "parse_engine"
+    = "caml_parse_engine"
 
 let env =
   { s_stack = Array.create 100 0;
diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli
index 7516fbce..08e6ca66 100644
--- a/stdlib/parsing.mli
+++ b/stdlib/parsing.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parsing.mli,v 1.17 2002/11/01 17:06:46 doligez Exp $ *)
+(* $Id: parsing.mli,v 1.18 2004/04/14 15:37:30 doligez Exp $ *)
 
 (** The run-time library for parsers generated by [ocamlyacc]. *)
 
@@ -30,7 +30,7 @@ val rhs_start : int -> int
 (** Same as {!Parsing.symbol_start} and {!Parsing.symbol_end}, but
    return the offset of the string matching the [n]th item on the
    right-hand side of the rule, where [n] is the integer parameter
-   to [lhs_start] and [lhs_end]. [n] is 1 for the leftmost item. *)
+   to [rhs_start] and [rhs_end]. [n] is 1 for the leftmost item. *)
 
 val rhs_end : int -> int
 (** See {!Parsing.rhs_start}. *)
diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
index 54cb7bfb..c4421c37 100644
--- a/stdlib/pervasives.ml
+++ b/stdlib/pervasives.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: pervasives.ml,v 1.67 2003/07/29 09:08:42 xleroy Exp $ *)
+(* $Id: pervasives.ml,v 1.75.6.1 2004/06/22 12:13:46 xleroy Exp $ *)
 
 (* type 'a option = None | Some of 'a *)
 
@@ -81,65 +81,60 @@ external (+.) : float -> float -> float = "%addfloat"
 external (-.) : float -> float -> float = "%subfloat"
 external ( *. ) : float -> float -> float = "%mulfloat"
 external (/.) : float -> float -> float = "%divfloat"
-external ( ** ) : float -> float -> float = "power_float" "pow" "float"
-external exp : float -> float = "exp_float" "exp" "float"
-external acos : float -> float = "acos_float" "acos" "float"
-external asin : float -> float = "asin_float" "asin" "float"
-external atan : float -> float = "atan_float" "atan" "float"
-external atan2 : float -> float -> float = "atan2_float" "atan2" "float"
-external cos : float -> float = "cos_float" "cos" "float"
-external cosh : float -> float = "cosh_float" "cosh" "float"
-external log : float -> float = "log_float" "log" "float"
-external log10 : float -> float = "log10_float" "log10" "float"
-external sin : float -> float = "sin_float" "sin" "float"
-external sinh : float -> float = "sinh_float" "sinh" "float"
-external sqrt : float -> float = "sqrt_float" "sqrt" "float"
-external tan : float -> float = "tan_float" "tan" "float"
-external tanh : float -> float = "tanh_float" "tanh" "float"
-external ceil : float -> float = "ceil_float" "ceil" "float"
-external floor : float -> float = "floor_float" "floor" "float"
+external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float"
+external exp : float -> float = "caml_exp_float" "exp" "float"
+external acos : float -> float = "caml_acos_float" "acos" "float"
+external asin : float -> float = "caml_asin_float" "asin" "float"
+external atan : float -> float = "caml_atan_float" "atan" "float"
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
+external cos : float -> float = "caml_cos_float" "cos" "float"
+external cosh : float -> float = "caml_cosh_float" "cosh" "float"
+external log : float -> float = "caml_log_float" "log" "float"
+external log10 : float -> float = "caml_log10_float" "log10" "float"
+external sin : float -> float = "caml_sin_float" "sin" "float"
+external sinh : float -> float = "caml_sinh_float" "sinh" "float"
+external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float"
+external tan : float -> float = "caml_tan_float" "tan" "float"
+external tanh : float -> float = "caml_tanh_float" "tanh" "float"
+external ceil : float -> float = "caml_ceil_float" "ceil" "float"
+external floor : float -> float = "caml_floor_float" "floor" "float"
 external abs_float : float -> float = "%absfloat"
-external mod_float : float -> float -> float = "fmod_float" "fmod" "float"
-external frexp : float -> float * int = "frexp_float"
-external ldexp : float -> int -> float = "ldexp_float"
-external modf : float -> float * float = "modf_float"
+external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
+external frexp : float -> float * int = "caml_frexp_float"
+external ldexp : float -> int -> float = "caml_ldexp_float"
+external modf : float -> float * float = "caml_modf_float"
 external float : int -> float = "%floatofint"
 external float_of_int : int -> float = "%floatofint"
 external truncate : float -> int = "%intoffloat"
 external int_of_float : float -> int = "%intoffloat"
-external float_of_bytes : string -> float = "float_of_bytes"
+external float_of_bits : int64 -> float = "caml_int64_float_of_bits"
 let infinity =
-  float_of_bytes "\127\240\000\000\000\000\000\000"
-              (* 0x7F F0 00 00 00 00 00 00 *)
+  float_of_bits 0x7F_F0_00_00_00_00_00_00L
 let neg_infinity =
-  float_of_bytes "\255\240\000\000\000\000\000\000"
-              (* 0xFF F0 00 00 00 00 00 00 *)
+  float_of_bits 0xFF_F0_00_00_00_00_00_00L
 let nan =
-  float_of_bytes "\127\240\000\000\000\000\000\001"
-              (* 0x7F F0 00 00 00 00 00 01 *)
+  float_of_bits 0x7F_F0_00_00_00_00_00_01L
 let max_float =
-  float_of_bytes "\127\239\255\255\255\255\255\255"
-              (* 0x7f ef ff ff ff ff ff ff *)
+  float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL
 let min_float =
-  float_of_bytes "\000\016\000\000\000\000\000\000"
-              (* 0x00 10 00 00 00 00 00 00 *)
+  float_of_bits 0x00_10_00_00_00_00_00_00L
 let epsilon_float =
-  float_of_bytes "\060\176\000\000\000\000\000\000"
-              (* 0x3c b0 00 00 00 00 00 00 *)
+  float_of_bits 0x3C_B0_00_00_00_00_00_00L
+  
 type fpclass =
     FP_normal
   | FP_subnormal
   | FP_zero
   | FP_infinite
   | FP_nan
-external classify_float: float -> fpclass = "classify_float"
+external classify_float: float -> fpclass = "caml_classify_float"
 
 (* String operations -- more in module String *)
 
 external string_length : string -> int = "%string_length"
-external string_create: int -> string = "create_string"
+external string_create: int -> string = "caml_create_string"
 external string_blit : string -> int -> string -> int -> int -> unit
-                     = "blit_string" "noalloc"
+                     = "caml_blit_string" "noalloc"
 
 let (^) s1 s2 =
   let l1 = string_length s1 and l2 = string_length s2 in
@@ -166,8 +161,8 @@ external snd : 'a * 'b -> 'b = "%field1"
 
 (* String conversion functions *)
 
-external format_int: string -> int -> string = "format_int"
-external format_float: string -> float -> string = "format_float"
+external format_int: string -> int -> string = "caml_format_int"
+external format_float: string -> float -> string = "caml_format_float"
 
 let string_of_bool b =
   if b then "true" else "false"
@@ -179,7 +174,7 @@ let bool_of_string = function
 let string_of_int n =
   format_int "%d" n
 
-external int_of_string : string -> int = "int_of_string"
+external int_of_string : string -> int = "caml_int_of_string"
 
 module String = struct
   external get : string -> int -> char = "%string_safe_get"
@@ -198,7 +193,7 @@ let valid_float_lexem s =
 
 let string_of_float f = valid_float_lexem (format_float "%.12g" f);;
 
-external float_of_string : string -> float = "float_of_string"
+external float_of_string : string -> float = "caml_float_of_string"
 
 (* List operations -- more in module List *)
 
@@ -212,8 +207,8 @@ let rec (@) l1 l2 =
 type in_channel
 type out_channel
 
-external open_descriptor_out: int -> out_channel = "caml_open_descriptor_out"
-external open_descriptor_in: int -> in_channel = "caml_open_descriptor_in"
+external open_descriptor_out: int -> out_channel = "caml_ml_open_descriptor_out"
+external open_descriptor_in: int -> in_channel = "caml_ml_open_descriptor_in"
 
 let stdin = open_descriptor_in 0
 let stdout = open_descriptor_out 1
@@ -226,7 +221,7 @@ type open_flag =
   | Open_creat | Open_trunc | Open_excl
   | Open_binary | Open_text | Open_nonblock
 
-external open_desc: string -> open_flag list -> int -> int = "sys_open"
+external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
 
 let open_out_gen mode perm name =
   open_descriptor_out(open_desc name mode perm)
@@ -237,10 +232,10 @@ let open_out name =
 let open_out_bin name =
   open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
 
-external flush : out_channel -> unit = "caml_flush"
+external flush : out_channel -> unit = "caml_ml_flush"
 
 external out_channels_list : unit -> out_channel list 
-                           = "caml_out_channels_list"
+                           = "caml_ml_out_channels_list"
 
 let flush_all () = 
   let rec iter = function
@@ -249,9 +244,9 @@ let flush_all () =
   in iter (out_channels_list ())
 
 external unsafe_output : out_channel -> string -> int -> int -> unit
-                       = "caml_output"
+                       = "caml_ml_output"
 
-external output_char : out_channel -> char -> unit = "caml_output_char"
+external output_char : out_channel -> char -> unit = "caml_ml_output_char"
 
 let output_string oc s =
   unsafe_output oc s 0 (string_length s)
@@ -261,23 +256,23 @@ let output oc s ofs len =
   then invalid_arg "output"
   else unsafe_output oc s ofs len
 
-external output_byte : out_channel -> int -> unit = "caml_output_char"
-external output_binary_int : out_channel -> int -> unit = "caml_output_int"
+external output_byte : out_channel -> int -> unit = "caml_ml_output_char"
+external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int"
 
 external marshal_to_channel : out_channel -> 'a -> unit list -> unit
-     = "output_value"
+     = "caml_output_value"
 let output_value chan v = marshal_to_channel chan v []
 
-external seek_out : out_channel -> int -> unit = "caml_seek_out"
-external pos_out : out_channel -> int = "caml_pos_out"
-external out_channel_length : out_channel -> int = "caml_channel_size"
-external close_out_channel : out_channel -> unit = "caml_close_channel"
+external seek_out : out_channel -> int -> unit = "caml_ml_seek_out"
+external pos_out : out_channel -> int = "caml_ml_pos_out"
+external out_channel_length : out_channel -> int = "caml_ml_channel_size"
+external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
 let close_out oc = flush oc; close_out_channel oc
 let close_out_noerr oc =
   (try flush oc with _ -> ());
   (try close_out_channel oc with _ -> ())
 external set_binary_mode_out : out_channel -> bool -> unit
-                             = "caml_set_binary_mode"
+                             = "caml_ml_set_binary_mode"
 
 (* General input functions *)
 
@@ -290,10 +285,10 @@ let open_in name =
 let open_in_bin name =
   open_in_gen [Open_rdonly; Open_binary] 0 name
 
-external input_char : in_channel -> char = "caml_input_char"
+external input_char : in_channel -> char = "caml_ml_input_char"
 
 external unsafe_input : in_channel -> string -> int -> int -> int 
-                      = "caml_input"
+                      = "caml_ml_input"
 
 let input ic s ofs len =
   if ofs < 0 || len < 0 || ofs > string_length s - len
@@ -313,7 +308,7 @@ let really_input ic s ofs len =
   then invalid_arg "really_input"
   else unsafe_really_input ic s ofs len
 
-external input_scan_line : in_channel -> int = "caml_input_scan_line"
+external input_scan_line : in_channel -> int = "caml_ml_input_scan_line"
 
 let input_line chan =
   let rec build_result buf pos = function
@@ -343,16 +338,16 @@ let input_line chan =
     end
   in scan [] 0
 
-external input_byte : in_channel -> int = "caml_input_char"
-external input_binary_int : in_channel -> int = "caml_input_int"
-external input_value : in_channel -> 'a = "input_value"
-external seek_in : in_channel -> int -> unit = "caml_seek_in"
-external pos_in : in_channel -> int = "caml_pos_in"
-external in_channel_length : in_channel -> int = "caml_channel_size"
-external close_in : in_channel -> unit = "caml_close_channel"
+external input_byte : in_channel -> int = "caml_ml_input_char"
+external input_binary_int : in_channel -> int = "caml_ml_input_int"
+external input_value : in_channel -> 'a = "caml_input_value"
+external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
+external pos_in : in_channel -> int = "caml_ml_pos_in"
+external in_channel_length : in_channel -> int = "caml_ml_channel_size"
+external close_in : in_channel -> unit = "caml_ml_close_channel"
 let close_in_noerr ic = (try close_in ic with _ -> ());;
 external set_binary_mode_in : in_channel -> bool -> unit
-                            = "caml_set_binary_mode"
+                            = "caml_ml_set_binary_mode"
 
 (* Output functions on standard output *)
 
@@ -384,12 +379,13 @@ let read_float () = float_of_string(read_line())
 
 module LargeFile =
   struct
-    external seek_out : out_channel -> int64 -> unit = "caml_seek_out_64"
-    external pos_out : out_channel -> int64 = "caml_pos_out_64"
-    external out_channel_length : out_channel -> int64 = "caml_channel_size_64"
-    external seek_in : in_channel -> int64 -> unit = "caml_seek_in_64"
-    external pos_in : in_channel -> int64 = "caml_pos_in_64"
-    external in_channel_length : in_channel -> int64 = "caml_channel_size_64"
+    external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64"
+    external pos_out : out_channel -> int64 = "caml_ml_pos_out_64"
+    external out_channel_length : out_channel -> int64
+                                = "caml_ml_channel_size_64"
+    external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64"
+    external pos_in : in_channel -> int64 = "caml_ml_pos_in_64"
+    external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64"
   end
 
 (* References *)
@@ -405,16 +401,24 @@ external decr: int ref -> unit = "%decr"
 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
 external format_of_string :
  ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity"
-external string_of_format : ('a, 'b, 'c, 'd) format4 -> string = "%identity"
-
+external string_of_format_sys :
+ ('a, 'b, 'c, 'd) format4 -> string = "%identity"
 external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity"
+
 let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 ->
               ('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 ->
-  string_to_format (string_of_format fmt1 ^ string_of_format fmt2);;
+  string_to_format (string_of_format_sys fmt1 ^ string_of_format_sys fmt2);;
+
+let string_of_format f =
+  let s = string_of_format_sys f in
+  let l = string_length s in
+  let r = string_create l in
+  string_blit s 0 r 0 l;
+  r
 
 (* Miscellaneous *)
 
-external sys_exit : int -> 'a = "sys_exit"
+external sys_exit : int -> 'a = "caml_sys_exit"
 
 let exit_function = ref flush_all
 
@@ -428,6 +432,7 @@ let exit retcode =
   do_at_exit ();
   sys_exit retcode
 
-external register_named_value: string -> 'a -> unit = "register_named_value"
+external register_named_value : string -> 'a -> unit
+                              = "caml_register_named_value"
 
 let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index 46630824..0b19d044 100644
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: pervasives.mli,v 1.94 2003/10/08 13:13:33 weis Exp $ *)
+(* $Id: pervasives.mli,v 1.99.2.2 2004/06/22 14:33:37 xleroy Exp $ *)
 
 (** The initially opened module.
 
@@ -48,8 +48,8 @@ external ( = ) : 'a -> 'a -> bool = "%equal"
    Mutable structures (e.g. references and arrays) are equal
    if and only if their current contents are structurally equal,
    even if the two mutable objects are not the same physical object.
-   Equality between functional values may raise [Invalid_argument].
-   Equality between cyclic data structures may not terminate. *)
+   Equality between functional values raises [Invalid_argument].
+   Equality between cyclic data structures does not terminate. *)
 
 external ( <> ) : 'a -> 'a -> bool = "%notequal"
 (** Negation of {!Pervasives.(=)}. *)
@@ -70,14 +70,27 @@ external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
    total ordering over all types.
    The ordering is compatible with [(=)]. As in the case
    of [(=)], mutable structures are compared by contents.
-   Comparison between functional values may raise [Invalid_argument].
-   Comparison between cyclic structures may not terminate. *)
+   Comparison between functional values raises [Invalid_argument].
+   Comparison between cyclic structures does not terminate. *)
 
 external compare : 'a -> 'a -> int = "%compare"
-(** [compare x y] returns [0] if [x=y], a negative integer if
-   [x<y], and a positive integer if [x>y]. The same restrictions
-   as for [=] apply. [compare] can be used as the comparison function
-   required by the {!Set.Make} and {!Map.Make} functors. *)
+(** [compare x y] returns [0] if [x] is equal to [y],
+   a negative integer if [x] is less than [y], and a positive integer
+   if [x] is greater than [y].  The ordering implemented by [compare]
+   is compatible with the comparison predicates [=], [<] and [>]
+   defined above,  with one difference on the treatment of the float value
+   {!Pervasives.nan}.  Namely, the comparison predicates treat [nan]
+   as different from any other float value, including itself;
+   while [compare] treats [nan] as equal to itself and less than any
+   other float value.  This treatment of [nan] ensures that [compare]
+   defines a total ordering relation.
+
+   [compare] applied to functional values may raise [Invalid_argument].
+   [compare] applied to cyclic structures may not terminate.
+
+   The [compare] function can be used as the comparison function
+   required by the {!Set.Make} and {!Map.Make} functors, as well as
+   the {!List.sort} and {!Array.sort} functions. *)
 
 val min : 'a -> 'a -> 'a
 (** Return the smaller of the two arguments. *)
@@ -92,7 +105,7 @@ external ( == ) : 'a -> 'a -> bool = "%eq"
    physical modification of [e1] also affects [e2].
    On non-mutable structures, the behavior of [(==)] is
    implementation-dependent; however, it is guaranteed that
-   [e1 == e2] implies [e1 = e2]. *)
+   [e1 == e2] implies [compare e1 e2 = 0]. *)
 
 external ( != ) : 'a -> 'a -> bool = "%noteq"
 (** Negation of {!Pervasives.(==)}. *)
@@ -234,55 +247,55 @@ external ( *. ) : float -> float -> float = "%mulfloat"
 external ( /. ) : float -> float -> float = "%divfloat"
 (** Floating-point division. *)
 
-external ( ** ) : float -> float -> float = "power_float" "pow" "float"
+external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float"
 (** Exponentiation *)
 
-external sqrt : float -> float = "sqrt_float" "sqrt" "float"
+external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float"
 (** Square root *)
 
-external exp : float -> float = "exp_float" "exp" "float"
+external exp : float -> float = "caml_exp_float" "exp" "float"
 (** Exponential. *)
 
-external log : float -> float = "log_float" "log" "float"
+external log : float -> float = "caml_log_float" "log" "float"
 (** Natural logarithm. *)
 
-external log10 : float -> float = "log10_float" "log10" "float"
+external log10 : float -> float = "caml_log10_float" "log10" "float"
 (** Base 10 logarithm. *)
 
-external cos : float -> float = "cos_float" "cos" "float"
+external cos : float -> float = "caml_cos_float" "cos" "float"
 (** See {!Pervasives.atan2}. *)
 
-external sin : float -> float = "sin_float" "sin" "float"
+external sin : float -> float = "caml_sin_float" "sin" "float"
 (** See {!Pervasives.atan2}. *)
 
-external tan : float -> float = "tan_float" "tan" "float"
+external tan : float -> float = "caml_tan_float" "tan" "float"
 (** See {!Pervasives.atan2}. *)
 
-external acos : float -> float = "acos_float" "acos" "float"
+external acos : float -> float = "caml_acos_float" "acos" "float"
 (** See {!Pervasives.atan2}. *)
 
-external asin : float -> float = "asin_float" "asin" "float"
+external asin : float -> float = "caml_asin_float" "asin" "float"
 (** See {!Pervasives.atan2}. *)
 
-external atan : float -> float = "atan_float" "atan" "float"
+external atan : float -> float = "caml_atan_float" "atan" "float"
 (** See {!Pervasives.atan2}. *)
 
-external atan2 : float -> float -> float = "atan2_float" "atan2" "float"
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
 (** The usual trigonometric functions. *)
 
-external cosh : float -> float = "cosh_float" "cosh" "float"
+external cosh : float -> float = "caml_cosh_float" "cosh" "float"
 (** See {!Pervasives.tanh}. *)
 
-external sinh : float -> float = "sinh_float" "sinh" "float"
+external sinh : float -> float = "caml_sinh_float" "sinh" "float"
 (** See {!Pervasives.tanh}. *)
 
-external tanh : float -> float = "tanh_float" "tanh" "float"
+external tanh : float -> float = "caml_tanh_float" "tanh" "float"
 (** The usual hyperbolic trigonometric functions. *)
 
-external ceil : float -> float = "ceil_float" "ceil" "float"
+external ceil : float -> float = "caml_ceil_float" "ceil" "float"
 (** See {!Pervasives.floor}. *)
 
-external floor : float -> float = "floor_float" "floor" "float"
+external floor : float -> float = "caml_floor_float" "floor" "float"
 (** Round the given float to an integer value.
    [floor f] returns the greatest integer value less than or
    equal to [f].
@@ -292,22 +305,22 @@ external floor : float -> float = "floor_float" "floor" "float"
 external abs_float : float -> float = "%absfloat"
 (** Return the absolute value of the argument. *)
 
-external mod_float : float -> float -> float = "fmod_float" "fmod" "float"
+external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
 (** [mod_float a b] returns the remainder of [a] with respect to
    [b].  The returned value is [a -. n *. b], where [n]
    is the quotient [a /. b] rounded towards zero to an integer. *)
 
-external frexp : float -> float * int = "frexp_float"
+external frexp : float -> float * int = "caml_frexp_float"
 (** [frexp f] returns the pair of the significant
    and the exponent of [f].  When [f] is zero, the
    significant [x] and the exponent [n] of [f] are equal to
    zero.  When [f] is non-zero, they are defined by
    [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *)
 
-external ldexp : float -> int -> float = "ldexp_float"
+external ldexp : float -> int -> float = "caml_ldexp_float"
 (** [ldexp x n] returns [x *. 2 ** n]. *)
 
-external modf : float -> float * float = "modf_float"
+external modf : float -> float * float = "caml_modf_float"
 (** [modf f] returns the pair of the fractional and integral
    part of [f]. *)
 
@@ -334,7 +347,10 @@ val neg_infinity : float
 val nan : float
 (** A special floating-point value denoting the result of an
    undefined operation such as [0.0 /. 0.0].  Stands for
-   ``not a number''. *)
+   ``not a number''.  Any floating-point operation with [nan] as
+   argument returns [nan] as result.  As for floating-point comparisons,
+   [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true]
+   if one or both of their arguments is [nan]. *)
 
 val max_float : float
 (** The largest positive finite value of type [float]. *)
@@ -354,7 +370,7 @@ type fpclass =
 (** The five classes of floating-point numbers, as determined by
    the {!Pervasives.classify_float} function. *)
 
-external classify_float : float -> fpclass = "classify_float"
+external classify_float : float -> fpclass = "caml_classify_float"
 (** Return the class of the given floating-point number:
    normal, subnormal, zero, infinite, or not a number. *)
 
@@ -406,18 +422,19 @@ val bool_of_string : string -> bool
 val string_of_int : int -> string
 (** Return the string representation of an integer, in decimal. *)
 
-external int_of_string : string -> int = "int_of_string"
+external int_of_string : string -> int = "caml_int_of_string"
 (** Convert the given string to an integer.
    The string is read in decimal (by default) or in hexadecimal (if it
    begins with [0x] or [0X]), octal (if it begins with [0o] or [0O]),
    or binary (if it begins with [0b] or [0B]).
    Raise [Failure "int_of_string"] if the given string is not
-   a valid representation of an integer. *)
+   a valid representation of an integer, or if the integer represented
+   exceeds the range of integers representable in type [int]. *)
 
 val string_of_float : float -> string
 (** Return the string representation of a floating-point number. *)
 
-external float_of_string : string -> float = "float_of_string"
+external float_of_string : string -> float = "caml_float_of_string"
 (** Convert the given string to a float.  Raise [Failure "float_of_string"]
    if the given string is not a valid representation of a float. *)
 
@@ -586,7 +603,9 @@ val output_byte : out_channel -> int -> unit
    256. *)
 
 val output_binary_int : out_channel -> int -> unit
-(** Write one integer in binary format on the given output channel.
+(** Write one integer in binary format (4 bytes, big-endian)
+   on the given output channel.
+   The given integer is taken modulo 2{^32}.
    The only reliable way to read it back is through the
    {!Pervasives.input_binary_int} function. The format is compatible across
    all machines for a given version of Objective Caml. *)
@@ -606,12 +625,14 @@ val seek_out : out_channel -> int -> unit
    the behavior is unspecified. *)
 
 val pos_out : out_channel -> int
-(** Return the current writing position for the given channel. *)
+(** Return the current writing position for the given channel.  Does
+    not work on channels opened with the [Open_append] flag (returns
+    unspecified results). *)
 
 val out_channel_length : out_channel -> int
-(** Return the total length (number of characters) of the
-   given channel.  This works only for regular files. On files of
-   other kinds, the result is meaningless. *)
+(** Return the size (number of characters) of the regular file
+   on which the given channel is opened.  If the channel is opened
+    on a file that is not a regular file, the result is meaningless. *)
 
 val close_out : out_channel -> unit
 (** Close the given channel, flushing all buffered write operations.
@@ -696,8 +717,8 @@ val input_byte : in_channel -> int
    Raise [End_of_file] if an end of file was reached. *)
 
 val input_binary_int : in_channel -> int
-(** Read an integer encoded in binary format from the given input
-   channel. See {!Pervasives.output_binary_int}.
+(** Read an integer encoded in binary format (4 bytes, big-endian)
+   from the given input channel. See {!Pervasives.output_binary_int}.
    Raise [End_of_file] if an end of file was reached while reading the
    integer. *)
 
@@ -717,9 +738,12 @@ val pos_in : in_channel -> int
 (** Return the current reading position for the given channel. *)
 
 val in_channel_length : in_channel -> int
-(** Return the total length (number of characters) of the
-   given channel. This works only for regular files. On files of
-   other kinds, the result is meaningless. *)
+(** Return the size (number of characters) of the regular file
+    on which the given channel is opened.  If the channel is opened
+    on a file that is not a regular file, the result is meaningless.
+    The returned size does not take into account the end-of-line
+    translations that can be performed when reading from a channel
+    opened in text mode. *)
 
 val close_in : in_channel -> unit
 (** Close the given channel.  Input functions raise a [Sys_error]
@@ -798,9 +822,9 @@ type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
     and ['b] is the type of the first argument given to
     [%a] and [%t] printing functions. *)
 
-external string_of_format :
-  ('a, 'b, 'c, 'd) format4 -> string = "%identity"
+val string_of_format : ('a, 'b, 'c, 'd) format4 -> string
 (** Converts a format string into a string. *)
+
 external format_of_string :
   ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity"
 (** [format_of_string s] returns a format string read from the string
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 314e6c16..77bf127d 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -11,17 +11,11 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printexc.ml,v 1.17 2003/01/21 12:57:33 doligez Exp $ *)
+(* $Id: printexc.ml,v 1.18 2004/01/16 15:24:02 doligez Exp $ *)
 
 open Printf;;
 
-let locfmt =
-  match Sys.os_type with
-  | "MacOS" ->
-      format_of_string "File \"%s\"; line %d; characters %d to %d ### %s"
-  | _ ->
-      format_of_string "File \"%s\", line %d, characters %d-%d: %s"
-;;
+let locfmt = format_of_string "File \"%s\", line %d, characters %d-%d: %s";;
 
 let field x i =
   let f = Obj.field x i in
diff --git a/stdlib/printf.ml b/stdlib/printf.ml
index bec3cf0a..3dc9d4f3 100644
--- a/stdlib/printf.ml
+++ b/stdlib/printf.ml
@@ -11,13 +11,14 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printf.ml,v 1.28 2003/07/05 11:17:52 xleroy Exp $ *)
-
-external format_int: string -> int -> string = "format_int"
-external format_int32: string -> int32 -> string = "int32_format"
-external format_nativeint: string -> nativeint -> string = "nativeint_format"
-external format_int64: string -> int64 -> string = "int64_format"
-external format_float: string -> float -> string = "format_float"
+(* $Id: printf.ml,v 1.30 2004/01/02 19:23:29 doligez Exp $ *)
+
+external format_int: string -> int -> string = "caml_format_int"
+external format_int32: string -> int32 -> string = "caml_int32_format"
+external format_nativeint: string -> nativeint -> string
+                         = "caml_nativeint_format"
+external format_int64: string -> int64 -> string = "caml_int64_format"
+external format_float: string -> float -> string = "caml_format_float"
 
 let bad_format fmt pos =
   invalid_arg
diff --git a/stdlib/random.ml b/stdlib/random.ml
index 29d0c76b..acdb3343 100644
--- a/stdlib/random.ml
+++ b/stdlib/random.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: random.ml,v 1.21 2003/06/19 18:14:52 doligez Exp $ *)
+(* $Id: random.ml,v 1.22 2003/12/16 18:09:43 doligez Exp $ *)
 
 (* "Linear feedback shift register" pseudo-random number generator. *)
 (* References: Robert Sedgewick, "Algorithms", Addison-Wesley *)
@@ -20,7 +20,7 @@
    It is seeded by a MD5-based PRNG.
 *)
 
-external random_seed: unit -> int = "sys_random_seed";;
+external random_seed: unit -> int = "caml_sys_random_seed";;
 
 module State = struct
 
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index 0c6ba026..367c6182 100644
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: scanf.ml,v 1.41 2003/07/15 07:25:09 weis Exp $ *)
+(* $Id: scanf.ml,v 1.49.2.2 2004/07/02 22:24:24 weis Exp $ *)
 
 (* The run-time library for scanners. *)
 
@@ -27,35 +27,36 @@ val stdib : scanbuf;;
 val next_char : scanbuf -> unit;;
 (** [Scanning.next_char scanbuf] advance the scanning buffer for
     one character.
-    Set a end of file condition if no character can be read. *)
+    If no more character can be read, sets a end of file condition and
+    returns '\000'. *)
 
 val peek_char : scanbuf -> char;;
 (** [Scanning.peek_char scanbuf] returns the current char available in
-    the input. *)
+    the buffer. *)
 
 val cautious_peek_char : scanbuf -> char;;
-(** [Scanning.cautious_peek_char scanbuf] returns the current char available in
-    the input or tries to read one if none has ever been read. *)
+(** [Scanning.cautious_peek_char scanbuf] returns the current char
+    available in the buffer or tries to read one if none has ever been
+    read. 
+    If no character can be read, sets a end of file condition and
+    returns '\000'. *)
 
 val checked_peek_char : scanbuf -> char;;
-(** Same as above but always returns a valid char instead of a null
-    char when the reading method of the input buffer has reached end of
-    file. *)
+(** Same as above but always returns a valid char or fails:
+    instead of returning a null char when the reading method of the
+    input buffer has reached an end of file, the function raises exception
+    [End_of_file]. *)
 
 val store_char : scanbuf -> char -> int -> int;;
 (** [Scanning.store_char scanbuf c lim] adds [c] to the token buffer
     of the scanning buffer. It also advances the scanning buffer for one
-    character and returns [lim - 1], indicating that there
-    is one less character to read. *)
+    character and returns [lim - 1], indicating the new limit
+    for the length of the current token. *)
 
 val skip_char : scanbuf -> char -> int -> int;;
 (** [Scanning.skip_char scanbuf c lim] is similar to [store_char] but
     it ignores (does not store in the token buffer) the character [c]. *)
 
-val char_count : scanbuf -> int;;
-(** [Scanning.char_count scanbuf] returns the number of characters read
-    from the given buffer. *)
-
 val token : scanbuf -> string;;
 (** [Scanning.token scanbuf] returns the string stored into the token
     buffer of the scanning buffer: it returns the token matched by the
@@ -65,6 +66,14 @@ val reset_token : scanbuf -> unit;;
 (** [Scanning.reset_token scanbuf] resets the token buffer of
     the given scanning buffer. *)
 
+val char_count : scanbuf -> int;;
+(** [Scanning.char_count scanbuf] returns the number of characters
+    read so far from the given buffer. *)
+
+val line_count : scanbuf -> int;;
+(** [Scanning.line_count scanbuf] returns the number of new line
+    characters read so far from the given buffer. *)
+
 val token_count : scanbuf -> int;;
 (** [Scanning.token_count scanbuf] returns the number of tokens read
     so far from [scanbuf]. *)
@@ -92,22 +101,29 @@ end;;
 module Scanning : SCANNING = struct
 
 (* The run-time library for scanf. *)
+type file_name = string;;
+
 type scanbuf = {
   mutable eof : bool;
   mutable bof : bool;
   mutable cur_char : char;
   mutable char_count : int;
+  mutable line_count : int;
   mutable token_count : int;
   mutable get_next_char : unit -> char;
   tokbuf : Buffer.t;
+  file_name : file_name;
 };;
 
-(* Reads a new character from input buffer, sets the end of file
-   condition if necessary. *)
+(* Reads a new character from input buffer.  Next_char never fails,
+   even in case of end of input: it then simply sets the end of file
+   condition. *)
 let next_char ib =
   try
-   ib.cur_char <- ib.get_next_char ();
-   ib.char_count <- ib.char_count + 1
+   let c = ib.get_next_char () in
+   ib.cur_char <- c;
+   ib.char_count <- ib.char_count + 1;
+   if c == '\n' then ib.line_count <- ib.line_count + 1
   with End_of_file ->
    ib.cur_char <- '\000';
    ib.eof <- true;;
@@ -135,13 +151,14 @@ let end_of_input ib =
   let c = cautious_peek_char ib in
   ib.eof;;
 let char_count ib = ib.char_count;;
+let line_count ib = ib.line_count;;
 let reset_token ib = Buffer.reset ib.tokbuf;;
 
 let token ib =
   let tokbuf = ib.tokbuf in
   let tok = Buffer.contents tokbuf in
   Buffer.clear tokbuf;
-  ib.token_count <- 1 + ib.token_count;
+  ib.token_count <- ib.token_count + 1;
   tok;;
 
 let token_count ib = ib.token_count;;
@@ -157,17 +174,17 @@ let skip_char ib c max =
 
 let default_token_buffer_size = 1024;;
 
-let create next =
-  let ib = {
-    bof = true;
-    eof = false;
-    cur_char = '\000';
-    char_count = 0;
-    get_next_char = next;
-    tokbuf = Buffer.create default_token_buffer_size;
-    token_count = 0;
-    } in
-  ib;;
+let create fname next = {
+  eof = false;
+  bof = true;
+  cur_char = '\000';
+  char_count = 0;
+  line_count = 0;
+  token_count = 0;
+  get_next_char = next;
+  tokbuf = Buffer.create default_token_buffer_size;
+  file_name = fname;
+};;
 
 let from_string s =
   let i = ref 0 in
@@ -177,14 +194,14 @@ let from_string s =
     let c = s.[!i] in
     incr i;
     c in
-  create next;;
+  create "string" next;;
 
-let from_function = create;;
+let from_function = create "function";;
 
 (* Perform bufferized input to improve efficiency. *)
 let file_buffer_size = ref 1024;;
 
-let from_file_channel ic =
+let from_file_channel fname ic =
   let len = !file_buffer_size in
   let buf = String.create len in
   let i = ref 0 in
@@ -197,16 +214,18 @@ let from_file_channel ic =
         buf.[0]
       end
     end in
-  create next;;
+  create fname next;;
 
-let from_file fname = from_file_channel (open_in fname);;
-let from_file_bin fname = from_file_channel (open_in_bin fname);;
+let from_file fname = from_file_channel fname (open_in fname);;
+let from_file_bin fname = from_file_channel fname (open_in_bin fname);;
 
-let from_channel ic =
+let from_input_channel fname ic =
   let next () = input_char ic in
-  create next;;
+  create fname next;;
 
-let stdib = from_channel stdin;;
+let from_channel = from_input_channel "in_channel";;
+
+let stdib = from_input_channel "stdin" stdin;;
 (** The scanning buffer reading from [stdin].*)
 
 end;;
@@ -220,32 +239,36 @@ let bad_input s = raise (Scan_failure s);;
 let bad_input_char c = bad_input (String.make 1 c);;
 
 let bad_input_escape c =
-  bad_input (Printf.sprintf "illegal escape character %c" c);;
+  bad_input (Printf.sprintf "illegal escape character %C" c);;
 
 let scanf_bad_input ib = function
   | Scan_failure s | Failure s ->
       let i = Scanning.char_count ib in
-      bad_input (Printf.sprintf "scanf: bad input at char number %i: %s" i s)
+      bad_input (Printf.sprintf "scanf: bad input at char number %i: %S" i s)
   | x -> raise x;;
 
 let bad_format fmt i fc =
   invalid_arg
     (Printf.sprintf
-       "scanf: bad format %c, at char number %i in format %s" fc i fmt);;
+       "scanf: bad conversion %%%c, at char number %i in format %S" fc i fmt);;
+
+let bad_float () = bad_input "no dot or exponent part found in float token";;
 
 (* Checking that the current char is indeed one of range, then skip it. *)
-let check_char_in ib range =
+let check_char_in range ib =
+  if range <> [] && not (Scanning.end_of_input ib) then
   let ci = Scanning.checked_peek_char ib in
-  if List.mem ci range then Scanning.next_char ib else
+  if List.memq ci range then Scanning.next_char ib else
   let sr = String.concat "" (List.map (String.make 1) range) in
   bad_input
-    (Printf.sprintf "looking for one of range %s, found %c" sr ci);;
+    (Printf.sprintf "looking for one of range %S, found %C" sr ci);;
 
 (* Checking that [c] is indeed in the input, then skip it. *)
 let check_char ib c =
   let ci = Scanning.checked_peek_char ib in
-  if ci = c then Scanning.next_char ib else
-  bad_input (Printf.sprintf "looking for %c, found %c" c ci);;
+  if ci != c
+  then bad_input (Printf.sprintf "looking for %C, found %C" c ci)
+  else Scanning.next_char ib;;
 
 (* Extracting tokens from ouput token buffer. *)
 
@@ -282,12 +305,12 @@ let token_float ib = float_of_string (Scanning.token ib);;
 (* To scan native ints, int32 and int64 integers.
    We cannot access to conversions to/from strings for those types,
    Nativeint.of_string, Int32.of_string, and Int64.of_string,
-   since those modules are not available to scanf.
+   since those modules are not available to Scanf.
    However, we can bind and use the corresponding primitives that are
    available in the runtime. *)
-external nativeint_of_string: string -> nativeint = "nativeint_of_string";;
-external int32_of_string : string -> int32 = "int32_of_string";;
-external int64_of_string : string -> int64 = "int64_of_string";;
+external nativeint_of_string: string -> nativeint = "caml_nativeint_of_string";;
+external int32_of_string : string -> int32 = "caml_int32_of_string";;
+external int64_of_string : string -> int64 = "caml_int64_of_string";;
 
 let token_nativeint conv ib = nativeint_of_string (token_int_literal conv ib);;
 let token_int32 conv ib = int32_of_string (token_int_literal conv ib);;
@@ -295,11 +318,20 @@ let token_int64 conv ib = int64_of_string (token_int_literal conv ib);;
 
 (* Scanning numbers. *)
 
-(* The decimal case is optimized. *)
+(* Digits scanning functions suppose that one character has been
+   checked and is available, since they return at end of file with the
+   currently found token selected. The digits scanning functions scan
+   a possibly empty sequence of digits, (hence a successful scanning
+   from one of those functions does not imply that the token is a
+   well-formed number: to get a true number, it is mandatory to check
+   that at least one digit is available before calling a digit
+   scanning function). *)
+
+(* The decimal case is treated especially for optimization purposes. *)
 let scan_decimal_digits max ib =
   let rec loop inside max =
     if max = 0 || Scanning.eof ib then max else
-    match Scanning.checked_peek_char ib with
+    match Scanning.cautious_peek_char ib with
     | '0' .. '9' as c ->
         let max = Scanning.store_char ib c max in
         loop true max
@@ -309,11 +341,12 @@ let scan_decimal_digits max ib =
     | c -> max in
   loop false max;;
 
-(* Other cases uses a predicate argument to scan_digits. *)
+(* To scan numbers from other bases, we use a predicate argument to
+   scan_digits. *)
 let scan_digits digitp max ib =
   let rec loop inside max =
     if max = 0 || Scanning.eof ib then max else
-    match Scanning.checked_peek_char ib with
+    match Scanning.cautious_peek_char ib with
     | c when digitp c ->
        let max = Scanning.store_char ib c max in
        loop true max
@@ -323,28 +356,41 @@ let scan_digits digitp max ib =
     | _ -> max in
   loop false max;;
 
-let scan_binary_digits =
-  let is_binary = function
+let scan_digits_plus digitp max ib =
+  let c = Scanning.checked_peek_char ib in
+  if digitp c then
+    let max = Scanning.store_char ib c max in
+    scan_digits digitp max ib
+  else bad_input_char c;;
+
+let is_binary_digit = function
   | '0' .. '1' -> true
-  | _ -> false in
-  scan_digits is_binary;;
+  | _ -> false;;
+
+let scan_binary_digits = scan_digits is_binary_digit;;
+let scan_binary_int = scan_digits_plus is_binary_digit;;
 
-let scan_octal_digits =
-  let is_octal = function
+let is_octal_digit = function
   | '0' .. '7' -> true
-  | _ -> false in
-  scan_digits is_octal;;
+  | _ -> false;;
 
-let scan_hexadecimal_digits =
-  let is_hexa = function
+let scan_octal_digits = scan_digits is_octal_digit;;
+let scan_octal_int = scan_digits_plus is_octal_digit;;
+
+let is_hexa_digit = function
   | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
-  | _ -> false in
-  scan_digits is_hexa;;
+  | _ -> false;;
+
+let scan_hexadecimal_digits = scan_digits is_hexa_digit;;
+let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;;
 
-(* Decimal integers. *)
+(* Scan a decimal integer. *)
 let scan_unsigned_decimal_int max ib =
-  if max = 0 || Scanning.eof ib then bad_input "decimal digit" else
-  scan_decimal_digits max ib;;
+  match Scanning.checked_peek_char ib with
+  | '0' .. '9' as c ->
+      let max = Scanning.store_char ib c max in
+      scan_decimal_digits max ib
+  | c -> bad_input_char c;;
 
 let scan_sign max ib =
   let c = Scanning.checked_peek_char ib in
@@ -372,28 +418,27 @@ let scan_unsigned_int max ib =
       | 'o' -> scan_octal_digits (Scanning.store_char ib c max) ib
       | 'b' -> scan_binary_digits (Scanning.store_char ib c max) ib
       | c -> scan_decimal_digits max ib end
-  | c -> scan_decimal_digits max ib;;
+  | c -> scan_unsigned_decimal_int max ib;;
 
 let scan_optionally_signed_int max ib =
   let max = scan_sign max ib in
-  if max = 0 || Scanning.eof ib then bad_input "bad int" else
   scan_unsigned_int max ib;;
 
-let scan_int conv max ib =
+let scan_int_conv conv max ib =
   match conv with
-  | 'b' -> scan_binary_digits max ib
+  | 'b' -> scan_binary_int max ib
   | 'd' -> scan_optionally_signed_decimal_int max ib
   | 'i' -> scan_optionally_signed_int max ib
-  | 'o' -> scan_octal_digits max ib
+  | 'o' -> scan_octal_int max ib
   | 'u' -> scan_unsigned_decimal_int max ib
-  | 'x' | 'X' -> scan_hexadecimal_digits max ib
+  | 'x' | 'X' -> scan_hexadecimal_int max ib
   | c -> assert false;;
 
 (* Scanning floating point numbers. *)
 (* Fractional part is optional and can be reduced to 0 digits. *)
 let scan_frac_part max ib =
   if max = 0 || Scanning.eof ib then max else
-  scan_unsigned_decimal_int max ib;;
+  scan_decimal_digits max ib;;
 
 (* Exp part is optional and can be reduced to 0 digits. *)
 let scan_exp_part max ib =
@@ -404,8 +449,17 @@ let scan_exp_part max ib =
      scan_optionally_signed_decimal_int (Scanning.store_char ib c max) ib
   | _ -> max;;
 
+(* An optional sign followed by a possibly empty sequence of decimal digits. *)
+let scan_optionally_signed_decimal_digits max ib =
+  let max = scan_sign max ib in
+  scan_decimal_digits max ib;;
+
+(* Scan the integer part of a floating point number, (not using the
+   Caml lexical convention since the integer part can be empty). *)
+let scan_int_part = scan_optionally_signed_decimal_digits;;
+
 let scan_float max ib =
-  let max = scan_optionally_signed_decimal_int max ib in
+  let max = scan_int_part max ib in
   if max = 0 || Scanning.eof ib then max else
   let c = Scanning.peek_char ib in
   match c with
@@ -416,7 +470,6 @@ let scan_float max ib =
   | c -> scan_exp_part max ib;;
 
 let scan_Float max ib =
-  let bad_float () = bad_input "no dot found in float" in
   let max = scan_optionally_signed_decimal_int max ib in
   if max = 0 || Scanning.eof ib then bad_float () else
   let c = Scanning.peek_char ib in
@@ -429,52 +482,43 @@ let scan_Float max ib =
      scan_exp_part max ib
   | c -> bad_float ();;
 
-(* Scan a regular string: it stops with a space or one of the
+(* Scan a regular string: stops when encountering a space or one of the
    characters in stp. It also stops when the maximum number of
    characters has been read.*)
 let scan_string stp max ib =
   let rec loop max =
-    if max = 0 || Scanning.eof ib then max else
+    if max = 0 || Scanning.end_of_input ib then max else
     let c = Scanning.checked_peek_char ib in
-    if stp = [] then
+    if stp == [] then
       match c with
       | ' ' | '\t' | '\n' | '\r' -> max
       | c -> loop (Scanning.store_char ib c max) else
     if List.mem c stp then max else
     loop (Scanning.store_char ib c max) in
   let max = loop max in
-  if stp <> [] then check_char_in ib stp;
+  check_char_in stp ib;
   max;;
 
 (* Scan a char: peek strictly one character in the input, whatsoever. *)
 let scan_char max ib =
   Scanning.store_char ib (Scanning.checked_peek_char ib) max;;
 
-let char_for_backslash =
-  match Sys.os_type with
-  | "Unix" | "Win32" | "Cygwin" ->
-      begin function
-      | 'n' -> '\010'
-      | 'r' -> '\013'
-      | 'b' -> '\008'
-      | 't' -> '\009'
-      | c   -> c
-      end
-  | "MacOS" ->
-      begin function
-      | 'n' -> '\013'
-      | 'r' -> '\010'
-      | 'b' -> '\008'
-      | 't' -> '\009'
-      | c   -> c
-      end
-  | x -> assert false;;
+let char_for_backslash = function
+  | 'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
+
+(* The integer value corresponding to the facial value of a valid
+   decimal digit character. *)
+let int_value_of_char c = int_of_char c - 48;;
 
 let char_for_decimal_code c0 c1 c2 =
   let c =
-    100 * (int_of_char c0 - 48) +
-     10 * (int_of_char c1 - 48) +
-          (int_of_char c2 - 48) in
+    100 * int_value_of_char c0 +
+     10 * int_value_of_char c1 +
+          int_value_of_char c2 in
   if c < 0 || c > 255
   then bad_input (Printf.sprintf "bad char \\%c%c%c" c0 c1 c2)
   else char_of_int c;;
@@ -547,73 +591,220 @@ let scan_bool max ib =
     | _ -> 0 in
   scan_string [] (min max m) ib;;
 
+(* Reading char sets in %[...] conversions. *)
 type char_set =
-   | Pos_set of string
-   | Neg_set of string;;
+   | Pos_set of string (* Positive (regular) set. *)
+   | Neg_set of string (* Negative (complementary) set. *);;
 
+(* Char sets are read as sub-strings in the format string. *)
 let read_char_set fmt i =
   let lim = String.length fmt - 1 in
 
-  let rec find_in_set i j =
+  let rec find_in_set j =
     if j > lim then bad_format fmt j fmt.[lim - 1] else
     match fmt.[j] with
-    | ']' -> String.sub fmt i (j - i), j
-    | c -> find_in_set i (j + 1)
-
-  and find_set_sign i =
-    if i > lim then bad_format fmt i fmt.[lim - 1] else
-    match fmt.[i] with
-    | '^' -> let set, i = find_set (i + 1) in i, Neg_set set
-    | _ -> let set, i = find_set i in i, Pos_set set
+    | ']' -> j
+    | c -> find_in_set (j + 1)
 
   and find_set i =
     if i > lim then bad_format fmt i fmt.[lim - 1] else
     match fmt.[i] with
-    | ']' -> find_in_set i (i + 1)
-    | c -> find_in_set i i in
-
-  find_set_sign i;;
+    | ']' -> find_in_set (i + 1)
+    | c -> find_in_set i in
+
+  if i > lim then bad_format fmt i fmt.[lim - 1] else
+  match fmt.[i] with
+  | '^' ->
+     let i = i + 1 in
+     let j = find_set i in
+     j, Neg_set (String.sub fmt i (j - i))
+  | _ ->
+     let j = find_set i in
+     j, Pos_set (String.sub fmt i (j - i));;
+
+(* Char sets are now represented as bitvects that are represented as
+   byte strings. *)
+
+(* Bit manipulations into bytes. *)
+let set_bit_of_byte byte idx b =
+  (b lsl idx) lor (byte land (* mask idx *) (lnot (1 lsl idx)));;
+
+let get_bit_of_byte byte idx = (byte lsr idx) land 1;;
+
+(* Bit manipulations in vectors of bytes represented as strings. *)
+let set_bit_of_range r c b =
+  let idx = c land 0x7 in
+  let ydx = c lsr 3 in
+  let byte = r.[ydx] in
+  r.[ydx] <- char_of_int (set_bit_of_byte (int_of_char byte) idx b);;
+
+let get_bit_of_range r c =
+  let idx = c land 0x7 in
+  let ydx = c lsr 3 in
+  let byte = r.[ydx] in
+  get_bit_of_byte (int_of_char byte) idx;;
+
+(* Char sets represented as bitvects represented as fixed length byte
+   strings. *)
+(* Create a full or empty set of chars. *)
+let make_range bit =
+  let c = char_of_int (if bit = 0 then 0 else 0xFF) in
+  String.make 32 c;;
+
+(* Test is a char belongs to a set of chars. *)
+let get_char_in_range r c = get_bit_of_range r (int_of_char c);;
+
+let bit_not b = (lnot b) land 1;;
+
+(* Build the bit vector corresponding to a char set read in the format. *)
+let make_bv bit set =
+  let r = make_range (bit_not bit) in
+  let lim = String.length set - 1 in
+  let rec loop bit rp i =
+    if i <= lim then
+    match set.[i] with
+    | '-' when rp ->
+       (* if i = 0 then rp is false (since the initial call is loop bit false 0)
+          hence i >= 1 and the following is safe. *)
+       let c1 = set.[i - 1] in
+       let i = i + 1 in
+       if i > lim then loop bit false (i - 1) else
+       let c2 = set.[i] in
+       for j = int_of_char c1 to int_of_char c2 do
+         set_bit_of_range r j bit done;
+       loop bit false (i + 1)
+    | c ->
+       set_bit_of_range r (int_of_char set.[i]) bit;
+       loop bit true (i + 1) in
+  loop bit false 0;
+  r;;
+
+(* Compute the predicate on chars corresponding to a char set. *)
+let make_pred bit set stp =
+  let r = make_bv bit set in
+  List.iter
+    (fun c -> set_bit_of_range r (int_of_char c) (bit_not bit)) stp;
+  (fun c -> get_char_in_range r c);;
 
 let make_setp stp char_set =
-  let make_predv set =
-    let v = Array.make 256 false in
-    let lim = String.length set - 1 in
-    let rec loop b i =
-      if i <= lim then
-      match set.[i] with
-      | '-' when b ->
-         (* if i = 0 then b is false (since the initial call is loop false 0)
-            hence i >= 1 and the following is safe. *)
-         let c1 = set.[i - 1] in
-         let i = i + 1 in
-         if i > lim then loop false (i - 1) else
-         let c2 = set.[i] in
-         for j = int_of_char c1 to int_of_char c2 do v.(j) <- true done;
-         loop false (i + 1)
-      | c -> v.(int_of_char set.[i]) <- true; loop true (i + 1) in
-    loop false 0;
-    v in
   match char_set with
   | Pos_set set ->
-      let v = make_predv set in
-      List.iter (fun c -> v.(int_of_char c) <- false) stp;
-      (fun c -> v.(int_of_char c))
+      begin match String.length set with
+      | 0 -> (fun c -> 0)
+      | 1 ->
+          let p = set.[0] in
+          (fun c -> if c == p then 1 else 0)
+      | 2 ->
+          let p1 = set.[0] and p2 = set.[1] in
+          (fun c -> if c == p1 || c == p2 then 1 else 0)
+      | 3 ->
+          let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in
+          if p2 = '-' then make_pred 1 set stp else
+          (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0)
+      | n -> make_pred 1 set stp
+      end
   | Neg_set set ->
-      let v = make_predv set in
-      List.iter (fun c -> v.(int_of_char c) <- true) stp;
-      (fun c -> not (v.(int_of_char c)));;
+      begin match String.length set with
+      | 0 -> (fun c -> 1)
+      | 1 ->
+          let p = set.[0] in
+          (fun c -> if c != p then 1 else 0)
+      | 2 ->
+          let p1 = set.[0] and p2 = set.[1] in
+          (fun c -> if c != p1 && c != p2 then 1 else 0)
+      | 3 ->
+          let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in
+          if p2 = '-' then make_pred 0 set stp else
+          (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0)
+      | n -> make_pred 0 set stp
+      end;;
+
+let setp_table = Hashtbl.create 7;;
+
+let add_setp stp char_set setp =
+  let char_set_tbl =
+    try Hashtbl.find setp_table char_set with
+    | Not_found ->
+        let char_set_tbl = Hashtbl.create 3 in
+        Hashtbl.add setp_table char_set char_set_tbl;
+        char_set_tbl in
+  Hashtbl.add char_set_tbl stp setp;;
+
+let find_setp stp char_set =
+  try Hashtbl.find (Hashtbl.find setp_table char_set) stp with
+  | Not_found ->
+     let setp = make_setp stp char_set in
+     add_setp stp char_set setp;
+     setp;;
 
 let scan_chars_in_char_set stp char_set max ib =
-  let setp = make_setp stp char_set in
-  let rec loop max =
+  let rec loop_pos1 cp1 max =
     let c = Scanning.cautious_peek_char ib in
-    if max = 0 || Scanning.eof ib then max else
-    if setp c then loop (Scanning.store_char ib c max) else
+    if max = 0 || Scanning.end_of_input ib then max else
+    if c == cp1
+    then loop_pos1 cp1 (Scanning.store_char ib c max)
+    else max
+  and loop_pos2 cp1 cp2 max =
+    let c = Scanning.cautious_peek_char ib in
+    if max = 0 || Scanning.end_of_input ib then max else
+    if c == cp1 || c == cp2
+    then loop_pos2 cp1 cp2 (Scanning.store_char ib c max)
+    else max
+  and loop_pos3 cp1 cp2 cp3 max =
+    let c = Scanning.cautious_peek_char ib in
+    if max = 0 || Scanning.end_of_input ib then max else
+    if c == cp1 || c == cp2 || c == cp3
+    then loop_pos3 cp1 cp2 cp3 (Scanning.store_char ib c max)
+    else max
+  and loop_neg1 cp1 max =
+    let c = Scanning.cautious_peek_char ib in
+    if max = 0 || Scanning.end_of_input ib then max else
+    if c != cp1
+    then loop_neg1 cp1 (Scanning.store_char ib c max)
+    else max
+  and loop_neg2 cp1 cp2 max =
+    let c = Scanning.cautious_peek_char ib in
+    if max = 0 || Scanning.end_of_input ib then max else
+    if c != cp1 && c != cp2
+    then loop_neg2 cp1 cp2 (Scanning.store_char ib c max)
+    else max
+  and loop_neg3 cp1 cp2 cp3 max =
+    let c = Scanning.cautious_peek_char ib in
+    if max = 0 || Scanning.end_of_input ib then max else
+    if c != cp1 && c != cp2 && c != cp3
+    then loop_neg3 cp1 cp2 cp3 (Scanning.store_char ib c max)
+    else max
+  and loop setp max =
+    let c = Scanning.cautious_peek_char ib in
+    if max = 0 || Scanning.end_of_input ib then max else
+    if setp c == 1 then loop setp (Scanning.store_char ib c max) else
     max in
-  let max = loop max in
-  if stp <> [] then check_char_in ib stp;
+
+  let max =
+    match char_set with
+    | Pos_set set ->
+        begin match String.length set with
+        | 0 -> loop (fun c -> 0) max
+        | 1 -> loop_pos1 set.[0] max
+        | 2 -> loop_pos2 set.[0] set.[1] max
+        | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] max
+        | n -> loop (find_setp stp char_set) max end
+    | Neg_set set ->
+        begin match String.length set with
+        | 0 -> loop (fun c -> 1) max
+        | 1 -> loop_neg1 set.[0] max
+        | 2 -> loop_neg2 set.[0] set.[1] max
+        | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max
+        | n -> loop (find_setp stp char_set) max end in
+  check_char_in stp ib;
   max;;
 
+let get_count t ib =
+  match t with
+  | 'l' -> Scanning.line_count ib
+  | 'n' -> Scanning.char_count ib
+  | _ -> Scanning.token_count ib;;
+
 let skip_whites ib =
   let rec loop = function
   | ' ' | '\t' | '\n' | '\r' ->
@@ -623,20 +814,25 @@ let skip_whites ib =
   if not (Scanning.eof ib) then
   loop (Scanning.cautious_peek_char ib);;
 
-(* Main scanning function:
-   it takes an input buffer, a format and a function.
-   Then it scans the format and the buffer in parallel to find out
-   tokens as specified by the format. When it founds one token, it converts
-   it as specified, remembers the converted value as a future
+(* The [kscanf] main scanning function.
+   It takes as arguments:
+     - an input buffer [ib] from which to read characters,
+     - an error handling function [ef],
+     - a format [fmt] that specifies what to read in the input,
+     - and a function [f] to pass the tokens read to.
+
+   Then [kscanf] scans the format and the buffer in parallel to find
+   out tokens as specified by the format; when it founds one token, it
+   converts it as specified, remembers the converted value as a future
    argument to the function [f], and continues scanning.
 
    If the entire scanning succeeds (i.e. the format string has been
    exhausted and the buffer has provided tokens according to the
    format string), the tokens are applied to [f].
 
-   If the scanning or some conversion fails, the scanning function
+   If the scanning or some conversion fails, the main scanning function
    aborts and applies the scanning buffer and a string that explains
-   the error to the error continuation [ef]. *)
+   the error to the error handling function [ef] (the error continuation). *)
 let kscanf ib ef fmt f =
   let fmt = string_of_format fmt in
   let lim = String.length fmt - 1 in
@@ -650,42 +846,21 @@ let kscanf ib ef fmt f =
     if i > lim then f else
     match fmt.[i] with
     | ' ' -> skip_whites ib; scan_fmt f (i + 1)
-    | '%' -> scan_fmt_width f (i + 1)
+    | '%' ->
+        if i > lim then bad_format fmt i '%' else
+        scan_conversion false max_int f (i + 1)
     | '@' as t ->
         let i = i + 1 in
-        if i > lim then bad_format fmt (i - 1) t else check_input fmt.[i] f i
-    | c -> check_input c f i
-
-  and check_input c f i =
-    check_char ib c;
-    scan_fmt f (i + 1)
+        if i > lim then bad_format fmt (i - 1) t else begin
+        check_char ib fmt.[i];
+        scan_fmt f (i + 1) end
+    | c -> check_char ib c; scan_fmt f (i + 1)
 
-  and scan_fmt_width f i =
-    if i > lim then bad_format fmt i '%' else
-    match fmt.[i] with
-    | '_' -> scan_fmt_fixed_width true f (i + 1)
-    | _ -> scan_fmt_fixed_width false f i
-
-  and scan_fmt_fixed_width skip f i =
-    match fmt.[i] with
-    | '0' .. '9' as c ->
-        let rec read_width accu i =
-          if i > lim then accu, i else
-          match fmt.[i] with
-          | '0' .. '9' as c ->
-              let accu = 10 * accu + (int_of_char c - int_of_char '0') in
-              read_width accu (i + 1)
-          | _ -> accu, i in
-        let max, j = read_width 0 i in
-        scan_fmt_conversion skip max f j
-    | _ -> scan_fmt_conversion skip max_int f i
-
-  and scan_fmt_conversion skip max f i =
+  and scan_conversion skip max f i =
     let stack = if skip then no_stack else stack in
-    if i > lim then bad_format fmt i fmt.[lim - 1] else
     match fmt.[i] with
     | '%' as c ->
-        check_input c f i
+        check_char ib c; scan_fmt f (i + 1)
     | 'c' when max = 0 ->
         let c = Scanning.checked_peek_char ib in
         scan_fmt (stack f c) (i + 1)
@@ -695,7 +870,7 @@ let kscanf ib ef fmt f =
           if conv = 'c' then scan_char max ib else scan_Char max ib in
         scan_fmt (stack f (token_char ib)) (i + 1)
     | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv ->
-        let x = scan_int conv max ib in
+        let x = scan_int_conv conv max ib in
         scan_fmt (stack f (token_int conv ib)) (i + 1)
     | 'f' | 'g' | 'G' | 'e' | 'E' ->
         let x = scan_float max ib in
@@ -720,25 +895,34 @@ let kscanf ib ef fmt f =
         scan_fmt (stack f (token_bool ib)) (i + 1)
     | 'l' | 'n' | 'L' as t ->
         let i = i + 1 in
-        if i > lim then
-          let x = Scanning.char_count ib in
-          scan_fmt (stack f x) i else begin
+        if i > lim then scan_fmt (stack f (get_count t ib)) i else begin
         match fmt.[i] with
         | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv ->
-            let x = scan_int conv max ib in
+            let x = scan_int_conv conv max ib in
             begin match t with
             | 'l' -> scan_fmt (stack f (token_int32 conv ib)) (i + 1)
             | 'L' -> scan_fmt (stack f (token_int64 conv ib)) (i + 1)
             | _ -> scan_fmt (stack f (token_nativeint conv ib)) (i + 1) end
-        | c ->
-            let x = Scanning.char_count ib in
-            scan_fmt (stack f x) i end
-    | 'N' ->
-        let x = Scanning.token_count ib in
-        scan_fmt (stack f x) (i + 1)
+        | c -> scan_fmt (stack f (get_count t ib)) i end
+    | 'N' as t ->
+        scan_fmt (stack f (get_count t ib)) (i + 1)
     | '!' as c ->
         if Scanning.end_of_input ib then scan_fmt f (i + 1)
         else bad_input "end of input not found"
+    | '_' ->
+        if i > lim then bad_format fmt i fmt.[lim - 1] else
+        scan_conversion true max f (i + 1)
+    | '0' .. '9' as c ->
+        let rec read_width accu i =
+          if i > lim then accu, i else
+          match fmt.[i] with
+          | '0' .. '9' as c ->
+             let accu = 10 * accu + int_value_of_char c in
+             read_width accu (i + 1)
+          | _ -> accu, i in
+        let max, i = read_width (int_value_of_char c) (i + 1) in
+        if i > lim then bad_format fmt i fmt.[lim - 1] else
+        scan_conversion skip max f i
     | c -> bad_format fmt i c
 
   and scan_fmt_stoppers i =
diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli
index 78e80c4a..9370ab3c 100644
--- a/stdlib/scanf.mli
+++ b/stdlib/scanf.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: scanf.mli,v 1.38 2003/07/15 07:25:09 weis Exp $ *)
+(* $Id: scanf.mli,v 1.45.6.1 2004/06/24 11:19:05 doligez Exp $ *)
 
 (** Formatted input functions. *)
 
@@ -122,7 +122,7 @@ val bscanf :
      specification is greater than 1.
    - [C]: reads a single delimited character (delimiters and special
      escaped characters follow the lexical conventions of Caml).
-   - [f], [e], [E], [g], [G], [F]: reads an optionally signed
+   - [f], [e], [E], [g], [G]: reads an optionally signed
      floating-point number in decimal notation, in the style [dddd.ddd
      e/E+-dd].
    - [F]: reads a floating point number according to the lexical
@@ -140,11 +140,14 @@ val bscanf :
    - [\[ range \]]: reads characters that matches one of the characters
      mentioned in the range of characters [range] (or not mentioned in
      it, if the range starts with [^]). Returns a [string] that can be
-     empty, if no character in the input matches the range.
+     empty, if no character in the input matches the range. Hence,
+     [\['0'-'9'\]] returns a string representing a decimal number or an empty
+     string if no decimal digit is found. 
      If a closing bracket appears in a range, it must occur as the
      first character of the range (or just after the [^] in case of
      range negation); hence [\[\]\]] matches a [\]] character and
      [\[^\]\]] matches any character that is not [\]].
+   - [l]: applies [f] to the number of lines read so far.
    - [n]: applies [f] to the number of characters read so far.
    - [N]: applies [f] to the number of tokens read so far.
    - [!]: matches the end of input condition.
@@ -159,18 +162,27 @@ val bscanf :
    For instance, [%6d] reads an integer, having at most 6 decimal digits;
    and [%4f] reads a float with at most 4 characters.
 
-   Scanning indications appear just after string conversions [s] and
+   Scanning indications appear just after the string conversions [s] and
    [\[ range \]] to delimit the end of the token. A scanning
    indication is introduced by a [@] character, followed by some
    constant character [c]. It means that the string token should end
    just before the next matching [c] (which is skipped). If no [c]
    character is encountered, the string token spreads as much as
-   possible.  For instance, ["%s@\t"] reads a string up to the next
+   possible. For instance, ["%s@\t"] reads a string up to the next
    tabulation character. If a scanning indication [\@c] does not
    follow a string conversion, it is ignored and treated as a plain
    [c] character.
 
-   Note:
+   Notes:
+
+   - the scanning indications introduce slight differences in the
+   syntax of [Scanf] format strings compared to those used by the
+   [Printf] module. However, scanning indications are similar to those
+   of the [Format] module; hence, when producing formatted text to be
+   scanned by [!Scanf.bscanf], it is wise to use printing functions
+   from [Format] (or, if you need to use functions from [Printf],
+   banish or carefully double check the format strings that contain
+   ['@'] characters).
 
    - in addition to relevant digits, ['_'] characters may appear
    inside numbers (this is reminiscent to the usual Caml
@@ -181,22 +193,22 @@ val bscanf :
    analysis and parsing. If it appears not expressive enough for your
    needs, several alternative exists: regular expressions (module
    [Str]), stream parsers, [ocamllex]-generated lexers,
-   [ocamlyacc]-generated parsers. *)
+   [ocamlyacc]-generated parsers. 
+*)
 
 val fscanf : in_channel -> ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;;
-
 (** Same as {!Scanf.bscanf}, but inputs from the given channel.
 
     Warning: since all scanning functions operate from a scanning
     buffer, be aware that each [fscanf] invocation must allocate a new
     fresh scanning buffer (unless careful use of partial evaluation in
-    the program).  Hence, there are chances that some characters seem
+    the program). Hence, there are chances that some characters seem
     to be skipped (in fact they are pending in the previously used
     buffer). This happens in particular when calling [fscanf] again
     after a scan involving a format that necessitates some look ahead
     (such as a format that ends by skipping whitespace in the input).
 
-    To avoid confusion, consider using [bscanf] with an explicitely
+    To avoid confusion, consider using [bscanf] with an explicitly
     created scanning buffer. Use for instance [Scanning.from_file f]
     to allocate the scanning buffer reading from file [f].
 
@@ -208,7 +220,7 @@ val sscanf : string -> ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;;
 
 val scanf : ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;;
 (** Same as {!Scanf.bscanf}, but reads from the predefined scanning
-    buffer [Scanning.stdib] that is connected to [stdin]. *)
+    buffer {!Scanf.Scanning.stdib} that is connected to [stdin]. *)
 
 val kscanf :
   Scanning.scanbuf -> (Scanning.scanbuf -> exn -> 'a) ->
diff --git a/stdlib/set.ml b/stdlib/set.ml
index bdb457fa..481ad128 100644
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: set.ml,v 1.16 2003/06/23 07:28:34 xleroy Exp $ *)
+(* $Id: set.ml,v 1.18 2004/04/23 10:01:54 xleroy Exp $ *)
 
 (* Sets over ordered types *)
 
@@ -48,6 +48,7 @@ module type S =
     val min_elt: t -> elt
     val max_elt: t -> elt
     val choose: t -> elt
+    val split: elt -> t -> t * bool * t
   end
 
 module Make(Ord: OrderedType) =
@@ -243,23 +244,26 @@ module Make(Ord: OrderedType) =
           | (l2, true, r2) ->
               concat (diff l1 l2) (diff r1 r2)
 
-    let rec compare_aux l1 l2 =
-        match (l1, l2) with
-        ([], []) -> 0
-      | ([], _)  -> -1
-      | (_, []) -> 1
-      | (Empty :: t1, Empty :: t2) ->
-          compare_aux t1 t2
-      | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
+    type enumeration = End | More of elt * t * enumeration
+
+    let rec cons_enum s e =
+      match s with
+        Empty -> e
+      | Node(l, v, r, _) -> cons_enum l (More(v, r, e))
+
+    let rec compare_aux e1 e2 =
+        match (e1, e2) with
+        (End, End) -> 0
+      | (End, _)  -> -1
+      | (_, End) -> 1
+      | (More(v1, r1, e1), More(v2, r2, e2)) ->
           let c = Ord.compare v1 v2 in
-          if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
-      | (Node(l1, v1, r1, _) :: t1, t2) ->
-          compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
-      | (t1, Node(l2, v2, r2, _) :: t2) ->
-          compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
+          if c <> 0
+          then c
+          else compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
 
     let compare s1 s2 =
-      compare_aux [s1] [s2]
+      compare_aux (cons_enum s1 End) (cons_enum s2 End)
 
     let equal s1 s2 =
       compare s1 s2 = 0
diff --git a/stdlib/set.mli b/stdlib/set.mli
index 53770296..d10a2e3b 100644
--- a/stdlib/set.mli
+++ b/stdlib/set.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: set.mli,v 1.27 2002/04/18 07:27:42 garrigue Exp $ *)
+(* $Id: set.mli,v 1.32 2004/04/23 10:01:54 xleroy Exp $ *)
 
 (** Sets over ordered types.
 
@@ -33,8 +33,8 @@ module type OrderedType =
           [f e1 e2] is zero if the elements [e1] and [e2] are equal,
           [f e1 e2] is strictly negative if [e1] is smaller than [e2],
           and [f e1 e2] is strictly positive if [e1] is greater than [e2].
-          Example: a suitable ordering function is
-          the generic structural comparison function {!Pervasives.compare}. *)
+          Example: a suitable ordering function is the generic structural
+          comparison function {!Pervasives.compare}. *)
   end
 (** Input signature of the functor {!Set.Make}. *)
 
@@ -89,14 +89,12 @@ module type S =
 
     val iter: (elt -> unit) -> t -> unit
     (** [iter f s] applies [f] in turn to all elements of [s].
-       The order in which the elements of [s] are presented to [f]
-       is unspecified. *)
+       The elements of [s] are presented to [f] in increasing order
+       with respect to the ordering over the type of the elements. *)
 
     val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
     (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
-       where [x1 ... xN] are the elements of [s].
-       The order in which elements of [s] are presented to [f] is
-       unspecified. *)
+       where [x1 ... xN] are the elements of [s], in increasing order. *)
 
     val for_all: (elt -> bool) -> t -> bool
     (** [for_all p s] checks if all elements of the set
@@ -138,6 +136,15 @@ module type S =
     (** Return one element of the given set, or raise [Not_found] if
        the set is empty. Which element is chosen is unspecified,
        but equal elements will be chosen for equal sets. *)
+
+    val split: elt -> t -> t * bool * t
+    (** [split x s] returns a triple [(l, present, r)], where
+          [l] is the set of elements of [s] that are
+          strictly less than [x];
+          [r] is the set of elements of [s] that are
+          strictly greater than [x];
+          [present] is [false] if [s] contains no element equal to [x],
+          or [true] if [s] contains an element equal to [x]. *)
   end
 (** Output signature of the functor {!Set.Make}. *)
 
diff --git a/stdlib/sort.ml b/stdlib/sort.ml
index fc1e0400..357ccb78 100644
--- a/stdlib/sort.ml
+++ b/stdlib/sort.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: sort.ml,v 1.8 2001/12/07 13:40:58 xleroy Exp $ *)
+(* $Id: sort.ml,v 1.9 2004/01/14 17:20:56 doligez Exp $ *)
 
 (* Merging and sorting *)
 
@@ -48,6 +48,9 @@ let swap arr i j =
   unsafe_set arr i (unsafe_get arr j);
   unsafe_set arr j tmp
 
+(* There is a known performance bug in the code below.  If you find
+   it, don't bother reporting it.  You're not supposed to use this
+   module anyway. *)
 let array cmp arr =
   let rec qsort lo hi =
     if hi - lo >= 6 then begin
diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli
index 26ea922d..c5cb45d4 100644
--- a/stdlib/stdLabels.mli
+++ b/stdlib/stdLabels.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stdLabels.mli,v 1.8 2002/01/04 03:39:46 garrigue Exp $ *)
+(* $Id: stdLabels.mli,v 1.11.2.1 2004/06/22 14:23:24 xleroy Exp $ *)
 
 (** Standard labeled libraries.
 
@@ -27,8 +27,8 @@ module Array :
     external length : 'a array -> int = "%array_length"
     external get : 'a array -> int -> 'a = "%array_safe_get"
     external set : 'a array -> int -> 'a -> unit = "%array_safe_set"
-    external make : int -> 'a -> 'a array = "make_vect"
-    external create : int -> 'a -> 'a array = "make_vect"
+    external make : int -> 'a -> 'a array = "caml_make_vect"
+    external create : int -> 'a -> 'a array = "caml_make_vect"
     val init : int -> f:(int -> 'a) -> 'a array
     val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
     val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
@@ -50,6 +50,7 @@ module Array :
     val fold_right : f:('a -> 'b -> 'b) -> 'a array -> init:'b -> 'b
     val sort : cmp:('a -> 'a -> int) -> 'a array -> unit
     val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
+    val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
     external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
     external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
   end
@@ -97,6 +98,8 @@ module List :
     val combine : 'a list -> 'b list -> ('a * 'b) list
     val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
     val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+    val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+    val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
   end
 
 module String :
@@ -104,7 +107,7 @@ module String :
     external length : string -> int = "%string_length"
     external get : string -> int -> char = "%string_safe_get"
     external set : string -> int -> char -> unit = "%string_safe_set"
-    external create : int -> string = "create_string"
+    external create : int -> string = "caml_create_string"
     val make : int -> char -> string
     val copy : string -> string
     val sub : string -> pos:int -> len:int -> string
@@ -126,11 +129,13 @@ module String :
     val lowercase : string -> string
     val capitalize : string -> string
     val uncapitalize : string -> string
+    type t = string
+    val compare: t -> t -> int
     external unsafe_get : string -> int -> char = "%string_unsafe_get"
     external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
     external unsafe_blit :
       src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int ->
-        unit = "blit_string" "noalloc"
-    external unsafe_fill :
-      string -> pos:int -> len:int -> char -> unit = "fill_string" "noalloc"
+        unit = "caml_blit_string" "noalloc"
+    external unsafe_fill : string -> pos:int -> len:int -> char -> unit
+      = "caml_fill_string" "noalloc"
   end
diff --git a/stdlib/string.ml b/stdlib/string.ml
index e8b17df5..9299bad2 100644
--- a/stdlib/string.ml
+++ b/stdlib/string.ml
@@ -11,20 +11,20 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: string.ml,v 1.24 2002/07/12 09:47:54 xleroy Exp $ *)
+(* $Id: string.ml,v 1.25 2003/12/16 18:09:43 doligez Exp $ *)
 
 (* String operations *)
 
 external length : string -> int = "%string_length"
 external get : string -> int -> char = "%string_safe_get"
 external set : string -> int -> char -> unit = "%string_safe_set"
-external create : int -> string = "create_string"
+external create : int -> string = "caml_create_string"
 external unsafe_get : string -> int -> char = "%string_unsafe_get"
 external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
 external unsafe_blit : string -> int -> string -> int -> int -> unit
-                     = "blit_string" "noalloc"
+                     = "caml_blit_string" "noalloc"
 external unsafe_fill : string -> int -> int -> char -> unit
-                     = "fill_string" "noalloc"
+                     = "caml_fill_string" "noalloc"
 
 let make n c =
   let s = create n in
@@ -78,7 +78,7 @@ let concat sep l =
         tl;
       r
 
-external is_printable: char -> bool = "is_printable"
+external is_printable: char -> bool = "caml_is_printable"
 external char_code: char -> int = "%identity"
 external char_chr: int -> char = "%identity"
 
diff --git a/stdlib/string.mli b/stdlib/string.mli
index ee7a91de..e0838677 100644
--- a/stdlib/string.mli
+++ b/stdlib/string.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: string.mli,v 1.33 2002/06/26 09:13:59 xleroy Exp $ *)
+(* $Id: string.mli,v 1.36 2004/02/20 10:09:30 doligez Exp $ *)
 
 (** String operations. *)
 
@@ -22,18 +22,20 @@ external get : string -> int -> char = "%string_safe_get"
 (** [String.get s n] returns character number [n] in string [s].
    The first character is character number 0.
    The last character is character number [String.length s - 1].
-   Raise [Invalid_argument] if [n] is outside the range
-   0 to [(String.length s - 1)].
-   You can also write [s.[n]] instead of [String.get s n]. *)
+   You can also write [s.[n]] instead of [String.get s n].
+
+   Raise [Invalid_argument "index out of bounds"]
+   if [n] is outside the range 0 to [(String.length s - 1)]. *)
+
 
 external set : string -> int -> char -> unit = "%string_safe_set"
 (** [String.set s n c] modifies string [s] in place,
    replacing the character number [n] by [c].
-   Raise [Invalid_argument] if [n] is outside the range
-   0 to [(String.length s - 1)].
-   You can also write [s.[n] <- c] instead of [String.set s n c]. *)
+   You can also write [s.[n] <- c] instead of [String.set s n c].
+   Raise [Invalid_argument "index out of bounds"]
+   if [n] is outside the range 0 to [(String.length s - 1)]. *)
 
-external create : int -> string = "create_string"
+external create : int -> string = "caml_create_string"
 (** [String.create n] returns a fresh string of length [n].
    The string initially contains arbitrary characters.
    Raise [Invalid_argument] if [n < 0] or [n > Sys.max_string_length].
@@ -136,10 +138,10 @@ val lowercase : string -> string
    Latin-1 (8859-1) character set. *)
 
 val capitalize : string -> string
-(** Return a copy of the argument, with the first letter set to uppercase. *)
+(** Return a copy of the argument, with the first character set to uppercase. *)
 
 val uncapitalize : string -> string
-(** Return a copy of the argument, with the first letter set to lowercase. *)
+(** Return a copy of the argument, with the first character set to lowercase. *)
 
 type t = string
 (** An alias for the type of strings. *)
@@ -155,6 +157,6 @@ val compare: t -> t -> int
 external unsafe_get : string -> int -> char = "%string_unsafe_get"
 external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
 external unsafe_blit :
-  string -> int -> string -> int -> int -> unit = "blit_string" "noalloc"
+  string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc"
 external unsafe_fill :
-  string -> int -> int -> char -> unit = "fill_string" "noalloc"
+  string -> int -> int -> char -> unit = "caml_fill_string" "noalloc"
diff --git a/stdlib/stringLabels.ml b/stdlib/stringLabels.ml
index 6e5744f8..77eb3451 100644
--- a/stdlib/stringLabels.ml
+++ b/stdlib/stringLabels.ml
@@ -11,8 +11,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stringLabels.ml,v 1.3 2001/12/07 13:41:00 xleroy Exp $ *)
+(* $Id: stringLabels.ml,v 1.4 2004/01/03 22:08:38 doligez Exp $ *)
 
-(* Module [SringLabels]: labelled String module *)
+(* Module [StringLabels]: labelled String module *)
 
 include String
diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli
index 60679658..c7aeb13a 100644
--- a/stdlib/stringLabels.mli
+++ b/stdlib/stringLabels.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stringLabels.mli,v 1.7 2001/12/07 13:41:00 xleroy Exp $ *)
+(* $Id: stringLabels.mli,v 1.8.6.1 2004/06/22 14:23:25 xleroy Exp $ *)
 
 (** String operations. *)
 
@@ -33,7 +33,7 @@ external set : string -> int -> char -> unit = "%string_safe_set"
    0 to [(String.length s - 1)].
    You can also write [s.[n] <- c] instead of [String.set s n c]. *)
 
-external create : int -> string = "create_string"
+external create : int -> string = "caml_create_string"
 (** [String.create n] returns a fresh string of length [n].
    The string initially contains arbitrary characters.
    Raise [Invalid_argument] if [n < 0] or [n > Sys.max_string_length].
@@ -142,6 +142,14 @@ val capitalize : string -> string
 val uncapitalize : string -> string
 (** Return a copy of the argument, with the first letter set to lowercase. *)
 
+type t = string
+(** An alias for the type of strings. *)
+
+val compare: t -> t -> int
+(** The comparison function for strings, with the same specification as
+    {!Pervasives.compare}.  Along with the type [t], this function [compare]
+    allows the module [String] to be passed as argument to the functors
+    {!Set.Make} and {!Map.Make}. *)
 
 (**/**)
 
@@ -149,6 +157,6 @@ external unsafe_get : string -> int -> char = "%string_unsafe_get"
 external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
 external unsafe_blit :
   src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int ->
-    unit = "blit_string" "noalloc"
+    unit = "caml_blit_string" "noalloc"
 external unsafe_fill :
-  string -> pos:int -> len:int -> char -> unit = "fill_string" "noalloc"
+  string -> pos:int -> len:int -> char -> unit = "caml_fill_string" "noalloc"
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
index f516a94a..68755e78 100644
--- a/stdlib/sys.ml
+++ b/stdlib/sys.ml
@@ -11,27 +11,27 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: sys.ml,v 1.80 2003/10/13 07:39:46 xleroy Exp $ *)
+(* $Id: sys.ml,v 1.101.2.4 2004/07/09 15:11:48 doligez Exp $ *)
 
 (* System interface *)
 
-external get_config: unit -> string * int = "sys_get_config"
-external get_argv: unit -> string * string array = "sys_get_argv"
+external get_config: unit -> string * int = "caml_sys_get_config"
+external get_argv: unit -> string * string array = "caml_sys_get_argv"
 
 let (executable_name, argv) = get_argv()
 let (os_type, word_size) = get_config()
 let max_array_length = (1 lsl (word_size - 10)) - 1;;
 let max_string_length = word_size / 8 * max_array_length - 1;;
 
-external file_exists: string -> bool = "sys_file_exists"
-external remove: string -> unit = "sys_remove"
-external rename : string -> string -> unit = "sys_rename"
-external getenv: string -> string = "sys_getenv"
-external command: string -> int = "sys_system_command"
-external time: unit -> float = "sys_time"
-external chdir: string -> unit = "sys_chdir"
-external getcwd: unit -> string = "sys_getcwd"
-external readdir : string -> string array = "sys_read_directory"
+external file_exists: string -> bool = "caml_sys_file_exists"
+external remove: string -> unit = "caml_sys_remove"
+external rename : string -> string -> unit = "caml_sys_rename"
+external getenv: string -> string = "caml_sys_getenv"
+external command: string -> int = "caml_sys_system_command"
+external time: unit -> float = "caml_sys_time"
+external chdir: string -> unit = "caml_sys_chdir"
+external getcwd: unit -> string = "caml_sys_getcwd"
+external readdir : string -> string array = "caml_sys_read_directory"
 
 let interactive = ref false
 
@@ -40,8 +40,8 @@ type signal_behavior =
   | Signal_ignore
   | Signal_handle of (int -> unit)
 
-external signal: int -> signal_behavior -> signal_behavior
-        = "install_signal_handler"
+external signal : int -> signal_behavior -> signal_behavior
+                = "caml_install_signal_handler"
 
 let set_signal sig_num sig_beh = ignore(signal sig_num sig_beh)
 
@@ -78,4 +78,4 @@ let catch_break on =
 
 (* OCaml version string, must be in the format described in sys.mli. *)
 
-let ocaml_version = "3.07+2";;
+let ocaml_version = "3.08+alpha2 (2004-07-09)";;
diff --git a/stdlib/sys.mli b/stdlib/sys.mli
index fbb83818..cc97a253 100644
--- a/stdlib/sys.mli
+++ b/stdlib/sys.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: sys.mli,v 1.39 2003/03/03 17:16:15 xleroy Exp $ *)
+(* $Id: sys.mli,v 1.45 2004/05/04 11:51:13 basile Exp $ *)
 
 (** System interface. *)
 
@@ -24,34 +24,36 @@ val argv : string array
 val executable_name : string
 (** The name of the file containing the executable currently running. *)
 
-external file_exists : string -> bool = "sys_file_exists"
+external file_exists : string -> bool = "caml_sys_file_exists"
 (** Test if a file with the given name exists. *)
 
-external remove : string -> unit = "sys_remove"
+external remove : string -> unit = "caml_sys_remove"
 (** Remove the given file name from the file system. *)
 
-external rename : string -> string -> unit = "sys_rename"
+external rename : string -> string -> unit = "caml_sys_rename"
 (** Rename a file. The first argument is the old name and the
-   second is the new name. *)
+   second is the new name. If there is already another file
+   under the new name, [rename] may replace it, or raise an
+   exception, depending on your operating system. *)
 
-external getenv : string -> string = "sys_getenv"
+external getenv : string -> string = "caml_sys_getenv"
 (** Return the value associated to a variable in the process
    environment. Raise [Not_found] if the variable is unbound. *)
 
-external command : string -> int = "sys_system_command"
+external command : string -> int = "caml_sys_system_command"
 (** Execute the given shell command and return its exit code. *)
 
-external time : unit -> float = "sys_time"
+external time : unit -> float = "caml_sys_time"
 (** Return the processor time, in seconds, used by the program
    since the beginning of execution. *)
 
-external chdir : string -> unit = "sys_chdir"
+external chdir : string -> unit = "caml_sys_chdir"
 (** Change the current working directory of the process. *)
 
-external getcwd : unit -> string = "sys_getcwd"
+external getcwd : unit -> string = "caml_sys_getcwd"
 (** Return the current working directory of the process. *)
 
-external readdir : string -> string array = "sys_read_directory"
+external readdir : string -> string array = "caml_sys_read_directory"
 (** Return the names of all files present in the given directory.
    Names denoting the current directory and the parent directory
    (["."] and [".."] in Unix) are not returned.  Each string in the
@@ -69,8 +71,7 @@ val os_type : string
 (** Operating system currently executing the Caml program. One of
 -  ["Unix"] (for all Unix versions, including Linux and Mac OS X),
 -  ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw),
--  ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin),
--  ["MacOS"] (for MacOS 9). *)
+-  ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *)
 
 val word_size : int
 (** Size of one word on the machine currently executing the Caml
@@ -98,10 +99,12 @@ type signal_behavior =
    number as argument. *)
 
 external signal :
-  int -> signal_behavior -> signal_behavior = "install_signal_handler"
-(** Set the behavior of the system on receipt of a given signal.
-   The first argument is the signal number.  Return the behavior
-   previously associated with the signal. *)
+  int -> signal_behavior -> signal_behavior = "caml_install_signal_handler"
+(** Set the behavior of the system on receipt of a given signal.  The
+   first argument is the signal number.  Return the behavior
+   previously associated with the signal. If the signal number is
+   invalid (or not available on your system), an [Invalid_argument]
+   exception is raised. *)
 
 val set_signal : int -> signal_behavior -> unit
 (** Same as {!Sys.signal} but return value is ignored. *)
@@ -188,6 +191,7 @@ val catch_break : bool -> unit
 
 val ocaml_version : string;;
 (** [ocaml_version] is the version of Objective Caml.
-    It is a string of the form ["major.minor[additional-info]"]
-    Where major and minor are integers, and [additional-info] is
-    a string that is empty or starts with a '+'. *)
+    It is a string of the form ["major.minor[.patchlevel][+additional-info]"]
+    Where [major], [minor], and [patchlevel] are integers, and
+    [additional-info] is an arbitrary string.  The [[.patchlevel]] and
+    [[+additional-info]] parts may be absent. *)
diff --git a/stdlib/weak.ml b/stdlib/weak.ml
index 6cd4bc5e..c7be1710 100644
--- a/stdlib/weak.ml
+++ b/stdlib/weak.ml
@@ -11,21 +11,21 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: weak.ml,v 1.12 2002/07/23 16:10:00 doligez Exp $ *)
+(* $Id: weak.ml,v 1.13 2004/01/01 16:42:41 doligez Exp $ *)
 
 
 (** Weak array operations *)
 
 type 'a t;;
 
-external create: int -> 'a t = "weak_create";;
+external create: int -> 'a t = "caml_weak_create";;
 
 let length x = Obj.size(Obj.repr x) - 1;;
 
-external set : 'a t -> int -> 'a option -> unit = "weak_set";;
-external get: 'a t -> int -> 'a option = "weak_get";;
-external get_copy: 'a t -> int -> 'a option = "weak_get_copy";;
-external check: 'a t -> int -> bool = "weak_check";;
+external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";;
+external get: 'a t -> int -> 'a option = "caml_weak_get";;
+external get_copy: 'a t -> int -> 'a option = "caml_weak_get_copy";;
+external check: 'a t -> int -> bool = "caml_weak_check";;
 
 let fill ar ofs len x =
   if ofs < 0 || len < 0 || ofs + len > length ar
diff --git a/stdlib/weak.mli b/stdlib/weak.mli
index 21eb9655..9789d075 100644
--- a/stdlib/weak.mli
+++ b/stdlib/weak.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: weak.mli,v 1.14 2003/03/12 16:41:39 doligez Exp $ *)
+(* $Id: weak.mli,v 1.15 2004/02/02 14:43:12 doligez Exp $ *)
 
 (** Arrays of weak pointers and hash tables of weak pointers. *)
 
@@ -95,7 +95,7 @@ val blit : 'a t -> int -> 'a t -> int -> int -> unit
     is [true].
 
     The [equal] relation must be able to work on a shallow copy of
-    the values and give the same result as with the value itself.
+    the values and give the same result as with the values themselves.
     *)
 
 module type S = sig
diff --git a/test/.cvsignore b/test/.cvsignore
new file mode 100644
index 00000000..66d34d73
--- /dev/null
+++ b/test/.cvsignore
@@ -0,0 +1,2 @@
+*.byt
+*.out
diff --git a/test/.depend b/test/.depend
new file mode 100644
index 00000000..ac5de61e
--- /dev/null
+++ b/test/.depend
@@ -0,0 +1,28 @@
+KB/equations.cmi: KB/terms.cmi 
+KB/kb.cmi: KB/equations.cmi KB/terms.cmi 
+KB/orderings.cmi: KB/terms.cmi 
+KB/equations.cmo: KB/equations.cmi KB/terms.cmi 
+KB/equations.cmx: KB/equations.cmi KB/terms.cmx 
+KB/kb.cmo: KB/kb.cmi KB/equations.cmi KB/terms.cmi 
+KB/kb.cmx: KB/kb.cmi KB/equations.cmx KB/terms.cmx 
+KB/kbmain.cmo: KB/kb.cmi KB/orderings.cmi KB/equations.cmi KB/terms.cmi 
+KB/kbmain.cmx: KB/kb.cmx KB/orderings.cmx KB/equations.cmx KB/terms.cmx 
+KB/orderings.cmo: KB/orderings.cmi KB/terms.cmi 
+KB/orderings.cmx: KB/orderings.cmi KB/terms.cmx 
+KB/terms.cmo: KB/terms.cmi 
+KB/terms.cmx: KB/terms.cmi 
+Lex/grammar.cmi: Lex/syntax.cmo 
+Lex/gram_aux.cmo: Lex/syntax.cmo 
+Lex/gram_aux.cmx: Lex/syntax.cmx 
+Lex/grammar.cmo: Lex/grammar.cmi Lex/gram_aux.cmo Lex/syntax.cmo 
+Lex/grammar.cmx: Lex/grammar.cmi Lex/gram_aux.cmx Lex/syntax.cmx 
+Lex/lexgen.cmo: Lex/syntax.cmo 
+Lex/lexgen.cmx: Lex/syntax.cmx 
+Lex/main.cmo: Lex/lexgen.cmo Lex/output.cmo Lex/grammar.cmi \
+    Lex/scanner.cmo Lex/syntax.cmo Lex/scan_aux.cmo 
+Lex/main.cmx: Lex/lexgen.cmx Lex/output.cmx Lex/grammar.cmx \
+    Lex/scanner.cmx Lex/syntax.cmx Lex/scan_aux.cmx 
+Lex/output.cmo: Lex/syntax.cmo 
+Lex/output.cmx: Lex/syntax.cmx 
+Lex/scanner.cmo: Lex/syntax.cmo Lex/scan_aux.cmo Lex/grammar.cmi 
+Lex/scanner.cmx: Lex/syntax.cmx Lex/scan_aux.cmx Lex/grammar.cmx 
diff --git a/test/KB/equations.ml b/test/KB/equations.ml
new file mode 100644
index 00000000..b041aaaa
--- /dev/null
+++ b/test/KB/equations.ml
@@ -0,0 +1,115 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: equations.ml,v 1.5 1999/11/17 18:58:35 xleroy Exp $ *)
+
+(****************** Equation manipulations *************)
+
+open Terms
+
+type rule = 
+  { number: int;
+    numvars: int;
+    lhs: term;
+    rhs: term }
+
+(* standardizes an equation so its variables are 1,2,... *)
+
+let mk_rule num m n =
+  let all_vars = union (vars m) (vars n) in
+  let counter = ref 0 in
+  let subst =
+    List.map (fun v -> incr counter; (v, Var !counter)) (List.rev all_vars) in
+  { number = num;
+    numvars = !counter;
+    lhs = substitute subst m;
+    rhs = substitute subst n }
+
+
+(* checks that rules are numbered in sequence and returns their number *)
+
+let check_rules rules =
+  let counter = ref 0 in
+  List.iter (fun r -> incr counter;
+                 if r.number <> !counter
+                 then failwith "Rule numbers not in sequence")
+       rules;
+  !counter
+
+
+let pretty_rule rule =
+  print_int rule.number; print_string " : ";
+  pretty_term rule.lhs; print_string " = "; pretty_term rule.rhs;
+  print_newline()
+
+
+let pretty_rules rules = List.iter pretty_rule rules
+ 
+(****************** Rewriting **************************)
+
+(* Top-level rewriting. Let eq:L=R be an equation, M be a term such that L<=M.
+   With sigma = matching L M, we define the image of M by eq as sigma(R) *)
+let reduce l m r =
+  substitute (matching l m) r
+
+(* Test whether m can be reduced by l, i.e. m contains an instance of l. *)
+
+let can_match l m =
+  try let _ = matching l m in true
+  with Failure _ -> false
+
+let rec reducible l m =
+  can_match l m ||
+   (match m with
+    | Term(_,sons) -> List.exists (reducible l) sons
+    |         _     -> false)
+
+(* Top-level rewriting with multiple rules. *)
+
+let rec mreduce rules m =
+  match rules with
+    [] -> failwith "mreduce"
+  | rule::rest ->
+      try
+        reduce rule.lhs m rule.rhs
+      with Failure _ ->
+        mreduce rest m
+
+
+(* One step of rewriting in leftmost-outermost strategy,
+   with multiple rules. Fails if no redex is found *)
+
+let rec mrewrite1 rules m =
+  try
+    mreduce rules m
+  with Failure _ ->
+    match m with
+      Var n -> failwith "mrewrite1"
+    | Term(f, sons) -> Term(f, mrewrite1_sons rules sons)
+
+and mrewrite1_sons rules = function
+    [] -> failwith "mrewrite1"
+  | son::rest ->
+      try
+        mrewrite1 rules son :: rest
+      with Failure _ ->
+        son :: mrewrite1_sons rules rest
+
+
+(* Iterating rewrite1. Returns a normal form. May loop forever *)
+
+let rec mrewrite_all rules m =
+  try
+    mrewrite_all rules (mrewrite1 rules m)
+  with Failure _ ->
+    m
+
diff --git a/test/KB/equations.mli b/test/KB/equations.mli
new file mode 100644
index 00000000..8030f5b2
--- /dev/null
+++ b/test/KB/equations.mli
@@ -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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: equations.mli,v 1.5 1999/11/17 18:58:35 xleroy Exp $ *)
+
+open Terms
+
+type rule = 
+  { number: int;
+    numvars: int;
+    lhs: term;
+    rhs: term }
+
+val mk_rule: int -> term -> term -> rule
+val check_rules: rule list -> int
+val pretty_rule: rule -> unit
+val pretty_rules: rule list -> unit
+val reduce: term -> term -> term -> term
+val reducible: term -> term -> bool
+val mreduce: rule list -> term -> term
+val mrewrite1: rule list -> term -> term
+val mrewrite1_sons: rule list -> term list -> term list
+val mrewrite_all: rule list -> term -> term
diff --git a/test/KB/kb.ml b/test/KB/kb.ml
new file mode 100644
index 00000000..6b729d58
--- /dev/null
+++ b/test/KB/kb.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: kb.ml,v 1.5 1999/11/17 18:58:35 xleroy Exp $ *)
+
+open Terms
+open Equations
+
+(****************** Critical pairs *********************)
+
+(* All (u,subst) such that N/u (&var) unifies with M,
+   with principal unifier subst *)
+
+let rec super m = function
+    Term(_,sons) as n ->
+      let rec collate n = function
+        [] -> []
+      | son::rest ->
+          List.map (fun (u, subst) -> (n::u, subst)) (super m son)
+          @ collate (n+1) rest in
+      let insides = collate 1 sons in
+        begin try
+          ([], unify m n) :: insides
+        with Failure _ ->
+          insides
+        end
+  | _ -> []
+
+
+(* Ex :
+let (m,_) = <<F(A,B)>> 
+and (n,_) = <<H(F(A,x),F(x,y))>> in super m n
+==> [[1],[2,Term ("B",[])];                      x <- B
+     [2],[2,Term ("A",[]); 1,Term ("B",[])]]     x <- A  y <- B
+*)
+
+(* All (u,subst), u&[], such that n/u unifies with m *)
+
+let super_strict m = function
+    Term(_,sons) ->
+      let rec collate n = function
+        [] -> []
+      | son::rest ->
+          List.map (fun (u, subst) -> (n::u, subst)) (super m son)
+          @ collate (n+1) rest in
+      collate 1 sons
+    | _ -> []
+
+
+(* Critical pairs of l1=r1 with l2=r2 *)
+(* critical_pairs : term_pair -> term_pair -> term_pair list *)
+let critical_pairs (l1,r1) (l2,r2) =
+  let mk_pair (u,subst) =
+     substitute subst (replace l2 u r1), substitute subst r2 in
+  List.map mk_pair (super l1 l2)
+
+(* Strict critical pairs of l1=r1 with l2=r2 *)
+(* strict_critical_pairs : term_pair -> term_pair -> term_pair list *)
+let strict_critical_pairs (l1,r1) (l2,r2) =
+  let mk_pair (u,subst) =
+    substitute subst (replace l2 u r1), substitute subst r2 in
+  List.map mk_pair (super_strict l1 l2)
+
+
+(* All critical pairs of eq1 with eq2 *)
+let mutual_critical_pairs eq1 eq2 =
+  (strict_critical_pairs eq1 eq2) @ (critical_pairs eq2 eq1)
+
+(* Renaming of variables *)
+
+let rename n (t1,t2) =
+  let rec ren_rec = function
+    Var k -> Var(k+n)
+  | Term(op,sons) -> Term(op, List.map ren_rec sons) in
+  (ren_rec t1, ren_rec t2)
+
+
+(************************ Completion ******************************)
+
+let deletion_message rule =
+  print_string "Rule ";print_int rule.number; print_string " deleted";
+  print_newline()
+
+
+(* Generate failure message *)
+let non_orientable (m,n) =
+    pretty_term m; print_string " = "; pretty_term n; print_newline()
+
+
+let rec partition p = function
+    [] -> ([], [])
+  | x::l -> let (l1, l2) = partition p l in
+            if p x then (x::l1, l2) else (l1, x::l2)
+
+
+let rec get_rule n = function
+    [] -> raise Not_found
+  | r::l -> if n = r.number then r else get_rule n l
+
+
+(* Improved Knuth-Bendix completion procedure *)
+
+let kb_completion greater = 
+  let rec kbrec j rules =
+  let rec process failures (k,l) eqs =
+(****
+     print_string "***kb_completion "; print_int j; print_newline();
+     pretty_rules rules;
+     List.iter non_orientable failures;
+     print_int k; print_string " "; print_int l; print_newline();
+     List.iter non_orientable eqs;
+***)
+    match eqs with
+      [] ->
+        if k<l then next_criticals failures (k+1,l) else
+        if l<j then next_criticals failures (1,l+1) else
+        begin match failures with
+            [] -> rules (* successful completion *)
+          | _  -> print_string "Non-orientable equations :"; print_newline();
+                  List.iter non_orientable failures;
+                  failwith "kb_completion"
+        end
+    | (m,n)::eqs ->
+        let m' = mrewrite_all rules m
+        and n' = mrewrite_all rules n
+        and enter_rule(left,right) =
+          let new_rule = mk_rule (j+1) left right in
+          pretty_rule new_rule;
+          let left_reducible rule = reducible left rule.lhs in
+          let (redl,irredl) = partition left_reducible rules in
+          List.iter deletion_message redl;
+          let right_reduce rule =
+            mk_rule rule.number rule.lhs
+                    (mrewrite_all (new_rule::rules) rule.rhs) in
+          let irreds = List.map right_reduce irredl in
+          let eqs' = List.map (fun rule -> (rule.lhs, rule.rhs)) redl in
+          kbrec (j+1) (new_rule::irreds) [] (k,l) (eqs @ eqs' @ failures) in
+(***
+        print_string "--- Considering "; non_orientable (m', n');
+***)
+        if m' = n' then process failures (k,l) eqs else
+        if greater(m',n') then enter_rule(m',n') else
+        if greater(n',m') then enter_rule(n',m') else
+        process ((m',n')::failures) (k,l) eqs
+
+  and next_criticals failures (k,l) =
+(****
+    print_string "***next_criticals ";
+    print_int k; print_string " "; print_int l ; print_newline();
+****)
+    try
+      let rl = get_rule l rules in
+      let el = (rl.lhs, rl.rhs) in
+        if k=l then
+          process failures (k,l)
+                  (strict_critical_pairs el (rename rl.numvars el))
+        else
+          try
+            let rk = get_rule k rules in 
+            let ek = (rk.lhs, rk.rhs) in
+              process failures (k,l)
+                      (mutual_critical_pairs el (rename rl.numvars ek))
+          with Not_found -> next_criticals failures (k+1,l)
+    with Not_found -> next_criticals failures (1,l+1)
+  in process
+  in kbrec
+
+
+(* complete_rules is assumed locally confluent, and checked Noetherian with
+  ordering greater, rules is any list of rules *)
+
+let kb_complete greater complete_rules rules =
+    let n = check_rules complete_rules
+    and eqs = List.map (fun rule -> (rule.lhs, rule.rhs)) rules in
+    let completed_rules =
+      kb_completion greater n complete_rules [] (n,n) eqs in
+    print_string "Canonical set found :"; print_newline();
+    pretty_rules (List.rev completed_rules)
+
diff --git a/test/KB/kb.mli b/test/KB/kb.mli
new file mode 100644
index 00000000..4969b10a
--- /dev/null
+++ b/test/KB/kb.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: kb.mli,v 1.4 1999/11/17 18:58:35 xleroy Exp $ *)
+
+open Terms
+open Equations
+
+val super: term -> term -> (int list * (int * term) list) list
+val super_strict: term -> term -> (int list * (int * term) list) list
+val critical_pairs: term * term -> term * term -> (term * term) list
+val strict_critical_pairs: term * term -> term * term -> (term * term) list
+val mutual_critical_pairs: term * term -> term * term -> (term * term) list
+val rename: int -> term * term -> term * term
+val deletion_message: rule -> unit
+val non_orientable: term * term -> unit
+val partition: ('a -> bool) -> 'a list -> 'a list * 'a list
+val get_rule: int -> rule list -> rule
+val kb_completion: (term * term -> bool) -> int -> rule list -> (term * term) list -> int * int -> (term * term) list -> rule list
+val kb_complete: (term * term -> bool) -> rule list -> rule list -> unit
diff --git a/test/KB/kbmain.ml b/test/KB/kbmain.ml
new file mode 100644
index 00000000..3a53d33c
--- /dev/null
+++ b/test/KB/kbmain.ml
@@ -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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: kbmain.ml,v 1.5 1999/11/17 18:58:36 xleroy Exp $ *)
+
+open Terms
+open Equations
+open Orderings
+open Kb
+
+(****
+let group_rules = [
+  { number = 1; numvars = 1;
+    lhs = Term("*", [Term("U",[]); Var 1]); rhs = Var 1 };
+  { number = 2; numvars = 1;
+    lhs = Term("*", [Term("I",[Var 1]); Var 1]); rhs = Term("U",[]) };
+  { number = 3; numvars = 3;
+    lhs = Term("*", [Term("*", [Var 1; Var 2]); Var 3]);
+    rhs = Term("*", [Var 1; Term("*", [Var 2; Var 3])]) }
+]
+****)
+
+let geom_rules = [
+  { number = 1; numvars = 1;
+    lhs = Term ("*",[(Term ("U",[])); (Var 1)]);
+    rhs = Var 1 };
+  { number = 2; numvars = 1;
+    lhs = Term ("*",[(Term ("I",[(Var 1)])); (Var 1)]);
+    rhs = Term ("U",[]) };
+  { number = 3; numvars = 3;
+    lhs = Term ("*",[(Term ("*",[(Var 1); (Var 2)])); (Var 3)]);
+    rhs = Term ("*",[(Var 1); (Term ("*",[(Var 2); (Var 3)]))]) };
+  { number = 4; numvars = 0;
+    lhs = Term ("*",[(Term ("A",[])); (Term ("B",[]))]);
+    rhs = Term ("*",[(Term ("B",[])); (Term ("A",[]))]) };
+  { number = 5; numvars = 0;
+    lhs = Term ("*",[(Term ("C",[])); (Term ("C",[]))]);
+    rhs = Term ("U",[]) };
+  { number = 6; numvars = 0;
+    lhs = Term("*",
+            [(Term ("C",[]));
+             (Term ("*",[(Term ("A",[])); (Term ("I",[(Term ("C",[]))]))]))]);
+    rhs = Term ("I",[(Term ("A",[]))]) };
+  { number = 7; numvars = 0;
+    lhs = Term("*",
+            [(Term ("C",[]));
+             (Term ("*",[(Term ("B",[])); (Term ("I",[(Term ("C",[]))]))]))]);
+    rhs = Term ("B",[]) }
+]
+
+let group_rank = function
+    "U" -> 0
+  | "*" -> 1
+  | "I" -> 2
+  | "B" -> 3
+  | "C" -> 4
+  | "A" -> 5
+  | _ -> assert false
+
+let group_precedence op1 op2 =
+  let r1 = group_rank op1
+  and r2 = group_rank op2 in
+    if r1 = r2 then Equal else
+    if r1 > r2 then Greater else NotGE
+
+let group_order = rpo group_precedence lex_ext 
+
+let greater pair =
+  match group_order pair with Greater -> true | _ -> false
+
+let _ = kb_complete greater [] geom_rules
+
diff --git a/test/KB/orderings.ml b/test/KB/orderings.ml
new file mode 100644
index 00000000..7e6604a9
--- /dev/null
+++ b/test/KB/orderings.ml
@@ -0,0 +1,99 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: orderings.ml,v 1.4 1999/11/17 18:58:36 xleroy Exp $ *)
+
+(*********************** Recursive Path Ordering ****************************)
+
+open Terms
+
+type ordering = 
+    Greater
+  | Equal
+  | NotGE
+
+let ge_ord order pair = match order pair with NotGE -> false | _ -> true
+and gt_ord order pair = match order pair with Greater -> true | _ -> false
+and eq_ord order pair = match order pair with Equal -> true | _ -> false
+
+
+let rec rem_eq equiv x = function
+     []  -> failwith "rem_eq"
+  | y::l -> if equiv (x,y) then l else y :: rem_eq equiv x l
+
+
+let diff_eq equiv (x,y) =
+  let rec diffrec = function
+      ([],_) as p -> p
+    | (h::t, y)   -> try
+                       diffrec (t, rem_eq equiv h y)
+                     with Failure _ ->
+                       let (x',y') = diffrec (t,y) in (h::x',y') in
+  if List.length x > List.length y then diffrec(y,x) else diffrec(x,y)
+
+
+(* Multiset extension of order *)
+
+let mult_ext order = function
+    Term(_,sons1), Term(_,sons2) ->
+      begin match diff_eq (eq_ord order) (sons1,sons2) with
+        ([],[]) -> Equal
+      | (l1,l2) ->
+           if List.for_all
+                (fun n -> List.exists (fun m -> gt_ord order (m,n)) l1) l2
+           then Greater else NotGE
+      end
+  | _ -> failwith "mult_ext"
+
+
+(* Lexicographic extension of order *)
+
+let lex_ext order = function
+    (Term(_,sons1) as m), (Term(_,sons2) as n) ->
+      let rec lexrec = function
+        ([] , []) -> Equal
+      | ([] , _ ) -> NotGE
+      | ( _ , []) -> Greater
+      | (x1::l1, x2::l2) ->
+          match order (x1,x2) with
+            Greater -> if List.for_all (fun n' -> gt_ord order (m,n')) l2 
+                       then Greater else NotGE
+          | Equal -> lexrec (l1,l2)
+          | NotGE -> if List.exists (fun m' -> ge_ord order (m',n)) l1 
+                     then Greater else NotGE in
+      lexrec (sons1, sons2)
+  | _ -> failwith "lex_ext"
+
+
+(* Recursive path ordering *)
+
+let rpo op_order ext = 
+  let rec rporec (m,n) =
+    if m = n then Equal else 
+      match m with
+          Var vm -> NotGE
+        | Term(op1,sons1) ->
+            match n with
+                Var vn ->
+                  if occurs vn m then Greater else NotGE
+              | Term(op2,sons2) ->
+                  match (op_order op1 op2) with
+                      Greater ->
+                        if List.for_all (fun n' -> gt_ord rporec (m,n')) sons2
+                        then Greater else NotGE
+                    | Equal ->
+                        ext rporec (m,n)
+                    | NotGE ->
+                        if List.exists (fun m' -> ge_ord rporec (m',n)) sons1
+                        then Greater else NotGE
+  in rporec
+
diff --git a/test/KB/orderings.mli b/test/KB/orderings.mli
new file mode 100644
index 00000000..460ee64e
--- /dev/null
+++ b/test/KB/orderings.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: orderings.mli,v 1.4 1999/11/17 18:58:37 xleroy Exp $ *)
+
+open Terms
+
+type ordering = 
+    Greater
+  | Equal
+  | NotGE
+
+val ge_ord: ('a -> ordering) -> 'a -> bool
+val gt_ord: ('a -> ordering) -> 'a -> bool
+val eq_ord: ('a -> ordering) -> 'a -> bool
+val rem_eq: ('a * 'b -> bool) -> 'a -> 'b list -> 'b list
+val diff_eq: ('a * 'a -> bool) -> 'a list * 'a list -> 'a list * 'a list
+val mult_ext: (term * term -> ordering) -> term * term -> ordering
+val lex_ext: (term * term -> ordering) -> term * term -> ordering
+val rpo: (string -> string -> ordering) ->
+         ((term * term -> ordering) -> term * term -> ordering) ->
+         term * term -> ordering
diff --git a/test/KB/terms.ml b/test/KB/terms.ml
new file mode 100644
index 00000000..91b3bf5e
--- /dev/null
+++ b/test/KB/terms.ml
@@ -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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: terms.ml,v 1.5 1999/11/17 18:58:37 xleroy Exp $ *)
+
+(****************** Term manipulations *****************)
+
+type term = 
+    Var of int
+  | Term of string * term list
+
+let rec union l1 l2 =
+  match l1 with
+    []   -> l2
+  | a::r -> if List.mem a l2 then union r l2 else a :: union r l2
+  
+
+let rec vars = function
+    Var n -> [n]
+  | Term(_,l) -> vars_of_list l
+and vars_of_list = function
+    [] -> []
+  | t::r -> union (vars t) (vars_of_list r)
+
+
+let rec substitute subst = function
+    Term(oper,sons) -> Term(oper, List.map (substitute subst) sons)
+  | Var(n) as t     -> try List.assoc n subst with Not_found -> t
+
+
+(* Term replacement: replace M u N is M[u<-N]. *)
+
+let rec replace m u n =
+  match (u, m) with
+    [], _ -> n
+  | i::u, Term(oper, sons) -> Term(oper, replace_nth i sons u n)
+  | _ -> failwith "replace"
+
+and replace_nth i sons u n =
+  match sons with
+    s::r -> if i = 1
+            then replace s u n :: r
+            else s :: replace_nth (i-1) r u n
+  | []   -> failwith "replace_nth"
+
+
+(* Term matching. *)
+
+let matching term1 term2 =
+  let rec match_rec subst t1 t2 =
+    match (t1, t2) with
+      Var v, _ ->
+        if List.mem_assoc v subst then
+          if t2 = List.assoc v subst then subst else failwith "matching"
+        else
+          (v, t2) :: subst
+    | Term(op1,sons1), Term(op2,sons2) ->
+        if op1 = op2
+        then List.fold_left2 match_rec subst sons1 sons2
+        else failwith "matching"
+    | _ -> failwith "matching" in
+  match_rec [] term1 term2
+
+
+(* A naive unification algorithm. *)
+
+let compsubst subst1 subst2 = 
+  (List.map (fun (v,t) -> (v, substitute subst1 t)) subst2) @ subst1
+
+
+let rec occurs n = function
+    Var m -> m = n
+  | Term(_,sons) -> List.exists (occurs n) sons
+
+
+let rec unify term1 term2 =
+  match (term1, term2) with
+    Var n1, _ ->
+      if term1 = term2 then []
+      else if occurs n1 term2 then failwith "unify"
+      else [n1, term2]
+  | term1, Var n2 ->
+      if occurs n2 term1 then failwith "unify"
+      else [n2, term1]
+  | Term(op1,sons1), Term(op2,sons2) ->
+      if op1 = op2 then
+        List.fold_left2 (fun s t1 t2 -> compsubst (unify (substitute s t1)
+                                                         (substitute s t2)) s)
+                   [] sons1 sons2
+      else failwith "unify"
+
+
+(* We need to print terms with variables independently from input terms
+  obtained by parsing. We give arbitrary names v1,v2,... to their variables.
+*)
+
+let infixes = ["+";"*"]
+
+let rec pretty_term = function
+    Var n ->
+      print_string "v"; print_int n
+  | Term (oper,sons) ->
+      if List.mem oper infixes then begin
+        match sons with
+            [s1;s2] ->
+              pretty_close s1; print_string oper; pretty_close s2
+          | _ ->
+              failwith "pretty_term : infix arity <> 2"
+      end else begin
+        print_string oper;
+        match sons with
+             []   -> ()
+          | t::lt -> print_string "(";
+                     pretty_term t;
+                     List.iter (fun t -> print_string ","; pretty_term t) lt;
+                     print_string ")"
+      end
+
+and pretty_close = function
+    Term(oper, _) as m ->
+      if List.mem oper infixes then begin
+        print_string "("; pretty_term m; print_string ")"
+      end else
+        pretty_term m
+  | m ->
+      pretty_term m
+
+
diff --git a/test/KB/terms.mli b/test/KB/terms.mli
new file mode 100644
index 00000000..004895e3
--- /dev/null
+++ b/test/KB/terms.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: terms.mli,v 1.4 1999/11/17 18:58:38 xleroy Exp $ *)
+
+type term = 
+    Var of int
+  | Term of string * term list
+
+val union: 'a list -> 'a list -> 'a list
+val vars: term -> int list
+val vars_of_list: term list -> int list
+val substitute: (int * term) list -> term -> term
+val replace: term -> int list -> term -> term
+val replace_nth: int -> term list -> int list -> term -> term list
+val matching: term -> term -> (int * term) list
+val compsubst: (int * term) list -> (int * term) list -> (int * term) list
+val occurs: int -> term -> bool
+val unify: term -> term -> (int * term) list
+val infixes: string list
+val pretty_term: term -> unit
+val pretty_close: term -> unit
diff --git a/test/Lex/.cvsignore b/test/Lex/.cvsignore
new file mode 100644
index 00000000..ed941f64
--- /dev/null
+++ b/test/Lex/.cvsignore
@@ -0,0 +1,5 @@
+grammar.ml
+grammar.mli
+scanner.ml
+testscanner.ml
+grammar.output
diff --git a/test/Lex/gram_aux.ml b/test/Lex/gram_aux.ml
new file mode 100644
index 00000000..6b23b5ec
--- /dev/null
+++ b/test/Lex/gram_aux.ml
@@ -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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: gram_aux.ml,v 1.4 1999/11/17 18:58:38 xleroy Exp $ *)
+
+(* Auxiliaries for the parser. *)
+
+open Syntax
+
+let regexp_for_string s =
+  let l = String.length s in
+  if l = 0 then
+    Epsilon
+  else begin
+    let re = ref(Characters [String.get s (l - 1)]) in
+    for i = l - 2 downto 0 do
+      re := Sequence(Characters [String.get s i], !re)
+    done;
+    !re
+  end
+
+
+let char_class c1 c2 =
+  let cl = ref [] in
+  for i = Char.code c2 downto Char.code c1 do
+    cl := Char.chr i :: !cl
+  done;
+  !cl
+
+
+let all_chars = char_class '\001' '\255'
+
+
+let rec subtract l1 l2 =
+  match l1 with
+    [] -> []
+  | a::l -> if List.mem a l2 then subtract l l2 else a :: subtract l l2
+
diff --git a/test/Lex/grammar.mly b/test/Lex/grammar.mly
new file mode 100644
index 00000000..ee5a8d24
--- /dev/null
+++ b/test/Lex/grammar.mly
@@ -0,0 +1,114 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: grammar.mly,v 1.4 1999/11/17 18:58:38 xleroy Exp $ */
+
+/* The grammar for lexer definitions */
+
+%{
+open Syntax
+open Gram_aux
+%}
+
+%token <string> Tident
+%token <char> Tchar
+%token <string> Tstring
+%token <Syntax.location> Taction
+%token Trule Tparse Tand Tequal Tend Tor Tunderscore Teof Tlbracket Trbracket
+%token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash
+
+%left Tor
+%left CONCAT
+%nonassoc Tmaybe
+%left Tstar
+%left Tplus
+
+%start lexer_definition
+%type <Syntax.lexer_definition> lexer_definition
+
+%%
+
+lexer_definition:
+    header Trule definition other_definitions Tend
+        { Lexdef($1, $3::(List.rev $4)) }
+;
+header:
+    Taction
+        { $1 }
+  |
+        { Location(0,0) }
+;
+other_definitions:
+    other_definitions Tand definition
+        { $3::$1 }
+  |     
+        { [] }
+;
+definition:
+    Tident Tequal entry
+        { ($1,$3) }
+;
+entry:
+    Tparse 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 all_chars }
+  | Teof
+        { Characters ['\000'] }
+  | Tchar
+        { Characters [$1] }
+  | Tstring
+        { regexp_for_string $1 }
+  | Tlbracket char_class Trbracket
+        { Characters $2 }
+  | regexp Tstar
+        { Repetition $1 }
+  | regexp Tmaybe
+        { Alternative($1, Epsilon) }
+  | regexp Tplus
+        { Sequence($1, Repetition $1) }
+  | regexp Tor regexp
+        { Alternative($1,$3) }
+  | regexp regexp %prec CONCAT
+        { Sequence($1,$2) }
+  | Tlparen regexp Trparen
+        { $2 }
+;
+char_class:
+    Tcaret char_class1
+        { subtract all_chars $2 }
+  | char_class1
+        { $1 }
+;
+char_class1:
+    Tchar Tdash Tchar
+        { char_class $1 $3 }
+  | Tchar
+        { [$1] }
+  | char_class char_class %prec CONCAT
+        { $1 @ $2 }
+;
+
+%%
+
diff --git a/test/Lex/lexgen.ml b/test/Lex/lexgen.ml
new file mode 100644
index 00000000..d17a74ce
--- /dev/null
+++ b/test/Lex/lexgen.ml
@@ -0,0 +1,266 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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.ml,v 1.5 2000/12/28 13:06:39 weis Exp $ *)
+
+(* Compiling a lexer definition *)
+
+open Syntax
+
+(* Deep abstract syntax for regular expressions *)
+
+type regexp =
+    Empty
+  | Chars of int
+  | Action of int
+  | Seq of regexp * regexp
+  | Alt of regexp * regexp
+  | Star of regexp
+
+(* From shallow to deep syntax *)
+
+(***
+
+let print_char_class c =
+  let print_interval low high =
+    prerr_int low;
+    if high - 1 > low then begin
+      prerr_char '-';
+      prerr_int (high-1)
+    end;
+    prerr_char ' ' in
+  let rec print_class first next = function
+    [] -> print_interval first next
+  | c::l ->
+      if char.code c = next
+      then print_class first (next+1) l
+      else begin
+        print_interval first next;
+        print_class (char.code c) (char.code c + 1) l
+      end in
+  match c with
+    [] -> prerr_newline()
+  | c::l -> print_class (char.code c) (char.code c + 1) l; prerr_newline()
+
+
+let rec print_regexp = function
+    Empty -> prerr_string "Empty"
+  | Chars n -> prerr_string "Chars "; prerr_int n
+  | Action n -> prerr_string "Action "; prerr_int n
+  | Seq(r1,r2) -> print_regexp r1; prerr_string "; "; print_regexp r2
+  | Alt(r1,r2) -> prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; prerr_string ")"
+  | Star r -> prerr_string "("; print_regexp r; prerr_string ")*"
+
+***)
+
+let chars = ref ([] : char list list)
+let chars_count = ref 0
+let actions = ref ([] : (int * location) list)
+let actions_count = ref 0
+
+let rec encode_regexp = function
+    Epsilon -> Empty
+  | Characters cl ->
+      let n = !chars_count in
+(***      prerr_int n; prerr_char ' '; print_char_class cl; ***)
+      chars := cl :: !chars;
+      chars_count := !chars_count + 1;
+      Chars(n)
+  | Sequence(r1,r2) ->
+      Seq(encode_regexp r1, encode_regexp r2)
+  | Alternative(r1,r2) ->
+      Alt(encode_regexp r1, encode_regexp r2)
+  | Repetition r ->
+      Star (encode_regexp r)
+
+
+let encode_casedef =
+  List.fold_left
+   (fun reg (expr,act) ->
+     let act_num = !actions_count in
+     actions_count := !actions_count + 1;
+     actions := (act_num, act) :: !actions;
+     Alt(reg, Seq(encode_regexp expr, Action act_num)))
+  Empty
+
+
+let encode_lexdef (Lexdef(_, ld)) =
+  chars := [];
+  chars_count := 0;
+  actions := [];
+  actions_count := 0;
+  let name_regexp_list =
+    List.map (fun (name, casedef) -> (name, encode_casedef casedef)) ld in
+(*  List.iter print_char_class chars; *)
+  let chr = Array.of_list (List.rev !chars)
+  and act = !actions in
+  chars := [];
+  actions := [];
+  (chr, name_regexp_list, act)
+
+
+(* To generate directly a NFA from a regular expression.
+   Confer Aho-Sethi-Ullman, dragon book, chap. 3 *)
+
+type transition =
+    OnChars of int
+  | ToAction of int
+
+
+let rec merge_trans l1 l2 =
+  match (l1, l2) with
+    ([], s2) -> s2
+  | (s1, []) -> s1
+  | ((OnChars n1 as t1) :: r1 as s1), ((OnChars n2 as t2) :: r2 as s2) ->
+      if n1 = n2 then t1 :: merge_trans r1 r2 else
+      if n1 < n2 then t1 :: merge_trans r1 s2 else
+                      t2 :: merge_trans s1 r2
+  | ((ToAction n1 as t1) :: r1 as s1), ((ToAction n2 as t2) :: r2 as s2) ->
+      if n1 = n2 then t1 :: merge_trans r1 r2 else
+      if n1 < n2 then t1 :: merge_trans r1 s2 else
+                      t2 :: merge_trans s1 r2
+  | ((OnChars n1 as t1) :: r1 as s1), ((ToAction n2 as t2) :: r2 as s2) ->
+      t1 :: merge_trans r1 s2
+  | ((ToAction n1 as t1) :: r1 as s1), ((OnChars n2 as t2) :: r2 as s2) ->
+      t2 :: merge_trans s1 r2
+
+
+let rec nullable = function
+    Empty      -> true
+  | Chars _    -> false
+  | Action _   -> false
+  | Seq(r1,r2) -> nullable r1 && nullable r2
+  | Alt(r1,r2) -> nullable r1 || nullable r2
+  | Star r     -> true
+
+
+let rec firstpos = function
+    Empty      -> []
+  | Chars pos  -> [OnChars pos]
+  | Action act -> [ToAction act]
+  | Seq(r1,r2) -> if nullable r1
+                  then merge_trans (firstpos r1) (firstpos r2)
+                  else firstpos r1
+  | Alt(r1,r2) -> merge_trans (firstpos r1) (firstpos r2)
+  | Star r     -> firstpos r
+
+
+let rec lastpos = function
+    Empty      -> []
+  | Chars pos  -> [OnChars pos]
+  | Action act -> [ToAction act]
+  | Seq(r1,r2) -> if nullable r2
+                  then merge_trans (lastpos r1) (lastpos r2)
+                  else lastpos r2
+  | Alt(r1,r2) -> merge_trans (lastpos r1) (lastpos r2)
+  | Star r     -> lastpos r
+
+
+let followpos size name_regexp_list =
+  let v = Array.create size [] in
+    let fill_pos first = function
+        OnChars pos -> v.(pos) <- merge_trans first v.(pos); ()
+      | ToAction _  -> () in
+    let rec fill = function
+        Seq(r1,r2) ->
+          fill r1; fill r2;
+          List.iter (fill_pos (firstpos r2)) (lastpos r1)
+      | Alt(r1,r2) ->
+          fill r1; fill r2
+      | Star r ->
+          fill r;
+          List.iter (fill_pos (firstpos r)) (lastpos r)
+      | _ -> () in
+    List.iter (fun (name, regexp) -> fill regexp) name_regexp_list;
+    v
+
+
+let no_action = 0x3FFFFFFF
+
+let split_trans_set =
+  List.fold_left
+    (fun (act, pos_set as act_pos_set) trans ->
+       match trans with
+         OnChars pos   -> (act, pos :: pos_set)
+       | ToAction act1 -> if act1 < act then (act1, pos_set)
+                                             else act_pos_set)
+    (no_action, [])
+
+
+let memory = (Hashtbl.create 131 : (transition list, int) Hashtbl.t)
+let todo = ref ([] : (transition list * int) list)
+let next = ref 0
+
+let get_state st = 
+  try
+    Hashtbl.find memory st
+  with Not_found ->
+    let nbr = !next in
+    next := !next + 1;
+    Hashtbl.add memory st nbr;
+    todo := (st, nbr) :: !todo;
+    nbr
+
+let rec map_on_states f =
+  match !todo with
+    []  -> []
+  | (st,i)::r -> todo := r; let res = f st in (res,i) :: map_on_states f
+
+let number_of_states () = !next
+
+let goto_state = function
+    [] -> Backtrack
+  | ps -> Goto (get_state ps)
+
+
+let transition_from chars follow pos_set = 
+  let tr = Array.create 256 []
+  and shift = Array.create 256 Backtrack in
+    List.iter
+      (fun pos ->
+        List.iter
+          (fun c ->
+             tr.(Char.code c) <-
+               merge_trans tr.(Char.code c) follow.(pos))
+          chars.(pos))
+      pos_set;
+    for i = 0 to 255 do
+      shift.(i) <- goto_state tr.(i)
+    done;
+    shift
+
+
+let translate_state chars follow state =
+  match split_trans_set state with
+    n, [] -> Perform n
+  | n, ps -> Shift( (if n = no_action then No_remember else Remember n),
+                    transition_from chars follow ps)
+
+
+let make_dfa lexdef =
+  let (chars, name_regexp_list, actions) =
+    encode_lexdef lexdef in
+(**
+  List.iter (fun (name, regexp) -> prerr_string name; prerr_string " = "; print_regexp regexp; prerr_newline()) name_regexp_list;
+**)
+  let follow =
+    followpos (Array.length chars) name_regexp_list in
+  let initial_states =
+    List.map (fun (name, regexp) -> (name, get_state(firstpos regexp)))
+             name_regexp_list in
+  let states =
+    map_on_states (translate_state chars follow) in
+  let v =
+    Array.create (number_of_states()) (Perform 0) in
+  List.iter (fun (auto, i) -> v.(i) <- auto) states;
+  (initial_states, v, actions)
+
diff --git a/test/Lex/main.ml b/test/Lex/main.ml
new file mode 100644
index 00000000..f0dc8b50
--- /dev/null
+++ b/test/Lex/main.ml
@@ -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: main.ml,v 1.4 1999/11/17 18:58:39 xleroy Exp $ *)
+
+(* The lexer generator. Command-line parsing. *)
+
+open Syntax
+open Scanner
+open Grammar
+open Lexgen
+open Output
+
+let main () =
+  if Array.length Sys.argv <> 2 then begin
+    prerr_string "Usage: camllex <input file>\n";
+    exit 2
+  end;
+  let source_name = Sys.argv.(1) in
+  let dest_name =
+    if Filename.check_suffix source_name ".mll" then
+      Filename.chop_suffix source_name ".mll" ^ ".ml"
+    else
+      source_name ^ ".ml" in
+  ic := open_in source_name;
+  oc := open_out dest_name;
+  let lexbuf = Lexing.from_channel !ic in
+  let (Lexdef(header,_) as def) =
+    try
+      Grammar.lexer_definition Scanner.main lexbuf
+    with
+      Parsing.Parse_error ->
+        prerr_string "Syntax error around char ";
+        prerr_int (Lexing.lexeme_start lexbuf);
+        prerr_endline ".";
+        exit 2
+    | Scan_aux.Lexical_error s ->
+        prerr_string "Lexical error around char ";
+        prerr_int (Lexing.lexeme_start lexbuf);
+        prerr_string ": ";
+        prerr_string s;
+        prerr_endline ".";
+        exit 2 in
+  let ((init, states, acts) as dfa) = make_dfa def in
+  output_lexdef header dfa;
+  close_in !ic;
+  close_out !oc
+
+let _ = main(); exit 0
+
+
+(*****
+let main () =
+  ic := stdin;
+  oc := stdout;
+  let lexbuf = lexing.from_channel ic in
+  let (Lexdef(header,_) as def) =
+    try
+      grammar.lexer_definition scanner.main lexbuf
+    with
+      parsing.Parse_error x ->
+        prerr_string "Syntax error around char ";
+        prerr_int (lexing.lexeme_start lexbuf);
+        prerr_endline ".";
+        sys.exit 2
+    | scan_aux.Lexical_error s ->
+        prerr_string "Lexical error around char ";
+        prerr_int (lexing.lexeme_start lexbuf);
+        prerr_string ": ";
+        prerr_string s;
+        prerr_endline ".";
+        sys.exit 2 in
+  let ((init, states, acts) as dfa) = make_dfa def in
+  output_lexdef header dfa
+
+****)
+
+(****
+let debug_scanner lexbuf =
+  let tok = scanner.main lexbuf in
+  begin match tok with
+    Tident s -> prerr_string "Tident "; prerr_string s
+  | Tchar c -> prerr_string "Tchar "; prerr_char c
+  | Tstring s -> prerr_string "Tstring "; prerr_string s
+  | Taction(Location(i1,i2)) ->
+      prerr_string "Taction "; prerr_int i1; prerr_string "-";
+      prerr_int i2
+  | Trule -> prerr_string "Trule"
+  | Tparse -> prerr_string "Tparse"
+  | Tand -> prerr_string "Tand"
+  | Tequal -> prerr_string "Tequal"
+  | Tend -> prerr_string "Tend"
+  | Tor -> prerr_string "Tor"
+  | Tunderscore -> prerr_string "Tunderscore"
+  | Teof -> prerr_string "Teof"
+  | Tlbracket -> prerr_string "Tlbracket"
+  | Trbracket -> prerr_string "Trbracket"
+  | Tstar -> prerr_string "Tstar"
+  | Tmaybe -> prerr_string "Tmaybe"
+  | Tplus -> prerr_string "Tplus"
+  | Tlparen -> prerr_string "Tlparen"
+  | Trparen -> prerr_string "Trparen"
+  | Tcaret -> prerr_string "Tcaret"
+  | Tdash -> prerr_string "Tdash"
+  end;
+  prerr_newline();
+  tok
+
+****)
diff --git a/test/Lex/output.ml b/test/Lex/output.ml
new file mode 100644
index 00000000..1107b5ad
--- /dev/null
+++ b/test/Lex/output.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: output.ml,v 1.5 2000/12/28 13:06:41 weis Exp $ *)
+
+(* Generating a DFA as a set of mutually recursive functions *)
+
+open Syntax
+
+let ic = ref stdin
+let oc = ref stdout
+
+(* 1- Generating the actions *)
+
+let copy_buffer = String.create 1024
+
+let copy_chunk (Location(start,stop)) =
+  seek_in !ic start;
+  let tocopy = ref(stop - start) in
+  while !tocopy > 0 do
+    let m =
+      input !ic copy_buffer 0 (min !tocopy (String.length copy_buffer)) in
+    output !oc copy_buffer 0 m;
+    tocopy := !tocopy - m
+  done
+
+
+let output_action (i,act) =
+  output_string !oc ("action_" ^ string_of_int i ^ " lexbuf = (\n");
+  copy_chunk act;
+  output_string !oc ")\nand "
+
+
+(* 2- Generating the states *)
+
+let states = ref ([||] : automata array)
+
+type occurrence =
+  { mutable pos: int list;
+    mutable freq: int }
+
+let enumerate_vect v =
+  let env = ref [] in
+  for pos = 0 to Array.length v - 1 do
+    try
+      let occ = List.assoc v.(pos) !env in
+      occ.pos <- pos :: occ.pos;
+      occ.freq <- occ.freq + 1
+    with Not_found ->
+      env := (v.(pos), {pos = [pos]; freq = 1 }) :: !env
+  done;
+  Sort.list (fun (e1, occ1) (e2, occ2) -> occ1.freq >= occ2.freq) !env
+
+
+let output_move = function
+    Backtrack ->
+      output_string !oc "lexing.backtrack lexbuf"
+  | Goto dest ->
+      match !states.(dest) with
+        Perform act_num ->
+          output_string !oc ("action_" ^ string_of_int act_num ^ " lexbuf")
+      | _ ->
+          output_string !oc ("state_" ^ string_of_int dest ^ " lexbuf")
+
+
+(* Cannot use standard char_for_read because the characters to escape
+   are not the same in CL6 and CL1999. *)
+
+let output_char_lit oc = function
+    '\'' -> output_string oc "\\'"
+  | '\\' -> output_string oc "\\\\"
+  | '\n' -> output_string oc "\\n"
+  | '\t' -> output_string oc "\\t"
+  | c ->  if Char.code c >= 32 && Char.code c < 128 then
+            output_char oc c
+          else begin
+            let n = Char.code c in
+            output_char oc '\\';
+            output_char oc (Char.chr (48 + n / 100));
+            output_char oc (Char.chr (48 + (n / 10) mod 10));
+            output_char oc (Char.chr (48 + n mod 10))
+          end
+
+let rec output_chars = function
+    [] ->
+      failwith "output_chars"
+  | [c] ->
+      output_string !oc "'";
+      output_char_lit !oc (Char.chr c);
+      output_string !oc "'"
+  | c::cl ->
+      output_string !oc "'";
+      output_char_lit !oc (Char.chr c);
+      output_string !oc "'|";
+      output_chars cl
+
+let output_one_trans (dest, occ) =
+  output_chars occ.pos;
+  output_string !oc " -> ";
+  output_move dest;
+  output_string !oc "\n |  "
+
+let output_all_trans trans =
+  output_string !oc "  match lexing.next_char lexbuf with\n    ";
+  match enumerate_vect trans with
+    [] ->
+      failwith "output_all_trans"
+  | (default, _) :: rest ->
+      List.iter output_one_trans rest;
+      output_string !oc "_ -> ";
+      output_move default;
+      output_string !oc "\nand "
+
+let output_state state_num = function
+    Perform i ->
+      ()
+  | Shift(what_to_do, moves) ->
+      output_string !oc
+        ("state_"  ^ string_of_int state_num ^ " lexbuf =\n");
+      begin match what_to_do with
+        No_remember -> ()
+      | Remember i ->
+          output_string !oc
+            ("  Lexing.set_backtrack lexbuf action_" ^
+             string_of_int i ^ ";\n")
+      end;
+      output_all_trans moves
+
+
+(* 3- Generating the entry points *)
+          
+let rec output_entries = function
+    [] -> failwith "output_entries"
+  | (name,state_num) :: rest ->
+      output_string !oc (name ^ " lexbuf =\n");
+      output_string !oc "  Lexing.init lexbuf;\n";
+      output_string !oc ("  state_" ^ string_of_int state_num ^
+                        " lexbuf\n");
+      match rest with
+        [] -> output_string !oc "\n"; ()
+      | _  -> output_string !oc "\nand "; output_entries rest
+
+
+(* All together *)
+
+let output_lexdef header (initial_st, st, actions) =
+  prerr_int (Array.length st); prerr_string " states, ";
+  prerr_int (List.length actions); prerr_string " actions.";
+  prerr_newline();
+  copy_chunk header;
+  output_string !oc "\nlet rec ";
+  states := st;
+  List.iter output_action actions;
+  for i = 0 to Array.length st - 1 do
+    output_state i st.(i)
+  done;
+  output_entries initial_st
+
+
+
diff --git a/test/Lex/scan_aux.ml b/test/Lex/scan_aux.ml
new file mode 100644
index 00000000..172d6f41
--- /dev/null
+++ b/test/Lex/scan_aux.ml
@@ -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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: scan_aux.ml,v 1.4 1999/11/17 18:58:39 xleroy Exp $ *)
+
+(* Auxiliaries for the lexical analyzer *)
+
+let brace_depth = ref 0
+let comment_depth = ref 0
+
+exception Lexical_error of string
+
+let initial_string_buffer = String.create 256
+let string_buff = ref initial_string_buffer
+let string_index = ref 0
+
+let reset_string_buffer () =
+  string_buff := initial_string_buffer;
+  string_index := 0
+
+
+let store_string_char c =
+  begin
+    if !string_index >= String.length !string_buff then begin
+      let new_buff = String.create (String.length !string_buff * 2) in
+      String.blit new_buff 0 !string_buff 0 (String.length !string_buff);
+      string_buff := new_buff
+    end
+  end;
+  String.unsafe_set !string_buff !string_index c;
+  incr string_index
+
+let get_stored_string () =
+  let s = String.sub !string_buff 0 !string_index in
+  string_buff := initial_string_buffer;
+  s
+
+
+let char_for_backslash = function
+    'n' -> '\010' (* '\n' when bootstrapped *)
+  | 't' -> '\009' (* '\t' *)
+  | 'b' -> '\008' (* '\b' *)
+  | 'r' -> '\013' (* '\r' *)
+  | c   -> c
+
+
+let char_for_decimal_code lexbuf i =
+  Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
+            10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
+                 (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48))
+
diff --git a/test/Lex/scanner.mll b/test/Lex/scanner.mll
new file mode 100644
index 00000000..c7d74b01
--- /dev/null
+++ b/test/Lex/scanner.mll
@@ -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: scanner.mll,v 1.5 1999/11/17 18:58:39 xleroy Exp $ *)
+
+(* The lexical analyzer for lexer definitions. *)
+
+{
+open Syntax
+open Grammar
+open Scan_aux
+}
+
+rule main = parse
+    [' ' '\010' '\013' '\009' ] + 
+    { main lexbuf }
+  | "(*" 
+    { comment_depth := 1;
+      comment lexbuf;
+      main lexbuf }
+  | (['A'-'Z' 'a'-'z'] | '_' ['A'-'Z' 'a'-'z' '\'' '0'-'9'])
+    ( '_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9'] ) * 
+    { match Lexing.lexeme lexbuf with
+        "rule" -> Trule
+      | "parse" -> Tparse
+      | "and" -> Tand
+      | "eof" -> Teof
+      | s -> Tident s }
+  | '"' 
+    { reset_string_buffer();
+      string lexbuf;
+      Tstring(get_stored_string()) }
+  | "'" 
+    { Tchar(char lexbuf) }
+  | '{' 
+    { let n1 = Lexing.lexeme_end lexbuf in
+        brace_depth := 1;
+        let n2 = action lexbuf in
+          Taction(Location(n1, n2)) }
+  | '='  { Tequal }
+  | ";;"  { Tend }
+  | '|'  { Tor }
+  | '_'  { Tunderscore }
+  | "eof"  { Teof }
+  | '['  { Tlbracket }
+  | ']'  { Trbracket }
+  | '*'  { Tstar }
+  | '?'  { Tmaybe }
+  | '+'  { Tplus }
+  | '('  { Tlparen }
+  | ')'  { Trparen }
+  | '^'  { Tcaret }
+  | '-'  { Tdash }
+  | eof
+    { raise(Lexical_error "unterminated lexer definition") }
+  | _
+    { raise(Lexical_error("illegal character " ^ Lexing.lexeme 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();
+      string lexbuf;
+      reset_string_buffer();
+      action lexbuf }
+  | '\''
+    { let _ = char lexbuf in action lexbuf }
+  | "(*" 
+    { comment_depth := 1;
+      comment lexbuf;
+      action lexbuf }
+  | eof 
+    { raise (Lexical_error "unterminated action") }
+  | _ 
+    { action lexbuf }
+      
+and string = parse
+    '"' 
+    { () }
+  | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] +
+    { string lexbuf }
+  | '\\' ['\\' '"' 'n' 't' 'b' 'r'] 
+    { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
+      string lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] 
+    { store_string_char(char_for_decimal_code lexbuf 1);
+      string lexbuf }
+  | eof 
+    { raise(Lexical_error "unterminated string") }
+  | _ 
+    { store_string_char(Lexing.lexeme_char lexbuf 0);
+      string lexbuf }
+
+and char = parse
+    [^ '\\'] "'" 
+    { Lexing.lexeme_char lexbuf 0 }
+  | '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" 
+    { char_for_backslash (Lexing.lexeme_char lexbuf 1) }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" 
+    { char_for_decimal_code lexbuf 1 }
+  | _ 
+    { raise(Lexical_error "bad character constant") }
+
+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 }
+  | eof 
+    { raise(Lexical_error "unterminated comment") }
+  | _ 
+    { comment lexbuf }
diff --git a/test/Lex/syntax.ml b/test/Lex/syntax.ml
new file mode 100644
index 00000000..14d2987a
--- /dev/null
+++ b/test/Lex/syntax.ml
@@ -0,0 +1,40 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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.4 1999/11/17 18:58:39 xleroy Exp $ *)
+
+(* The shallow abstract syntax *)
+
+type location =
+    Location of int * int
+
+type regular_expression =
+    Epsilon
+  | Characters of char list
+  | Sequence of regular_expression * regular_expression
+  | Alternative of regular_expression * regular_expression
+  | Repetition of regular_expression
+
+type lexer_definition =
+    Lexdef of location * (string * (regular_expression * location) list) list
+
+(* Representation of automata *)
+
+type automata =
+    Perform of int
+  | Shift of automata_trans * automata_move array
+and automata_trans =
+    No_remember
+  | Remember of int
+and automata_move =
+    Backtrack
+  | Goto of int
diff --git a/test/Lex/testmain.ml b/test/Lex/testmain.ml
new file mode 100644
index 00000000..ab9e4369
--- /dev/null
+++ b/test/Lex/testmain.ml
@@ -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: testmain.ml,v 1.4 1999/11/17 18:58:39 xleroy Exp $ *)
+
+(* The lexer generator. Command-line parsing. *)
+
+#open "syntax";;
+#open "testscanner";;
+#open "grammar";;
+#open "lexgen";;
+#open "output";;
+
+let main () =
+  ic := stdin;
+  oc := stdout;
+  let lexbuf = lexing.from_channel ic in
+  let (Lexdef(header,_) as def) =
+    try
+      grammar.lexer_definition testscanner.main lexbuf
+    with
+      parsing.Parse_error x ->
+        prerr_string "Syntax error around char ";
+        prerr_int (lexing.lexeme_start lexbuf);
+        prerr_endline ".";
+        sys.exit 2
+    | scan_aux.Lexical_error s ->
+        prerr_string "Lexical error around char ";
+        prerr_int (lexing.lexeme_start lexbuf);
+        prerr_string ": ";
+        prerr_string s;
+        prerr_endline ".";
+        sys.exit 2 in
+  let ((init, states, acts) as dfa) = make_dfa def in
+  output_lexdef header dfa
+;;
+
+main(); sys.exit 0
+;;
diff --git a/test/Lex/testscanner.mll b/test/Lex/testscanner.mll
new file mode 100644
index 00000000..1f2ffe69
--- /dev/null
+++ b/test/Lex/testscanner.mll
@@ -0,0 +1,135 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: testscanner.mll,v 1.4 1999/11/17 18:58:39 xleroy Exp $ *)
+
+(* The lexical analyzer for lexer definitions. *)
+
+{
+#open "syntax";;
+#open "grammar";;
+#open "scan_aux";;
+}
+
+rule main = parse
+    _ * "qwertyuiopasdfghjklzxcvbnm0123456789!@#$%^&*()"
+    { main lexbuf }
+  | [' ' '\010' '\013' '\009' ] + 
+    { main lexbuf }
+  | "(*" 
+    { comment_depth := 1;
+      comment lexbuf;
+      main lexbuf }
+  | (['A'-'Z' 'a'-'z'] | '_' ['A'-'Z' 'a'-'z' '\'' '0'-'9'])
+    ( '_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9'] ) * 
+    { match lexing.lexeme lexbuf with
+        "rule" -> Trule
+      | "parse" -> Tparse
+      | "and" -> Tand
+      | "eof" -> Teof
+      | s -> Tident s }
+  | '"' 
+    { reset_string_buffer();
+      string lexbuf;
+      Tstring(get_stored_string()) }
+  | "'" 
+    { Tchar(char lexbuf) }
+  | '{' 
+    { let n1 = lexing.lexeme_end lexbuf in
+        brace_depth := 1;
+        let n2 = action lexbuf in
+          Taction(Location(n1, n2)) }
+  | '='  { Tequal }
+  | ";;"  { Tend }
+  | '|'  { Tor }
+  | '_'  { Tunderscore }
+  | "eof"  { Teof }
+  | '['  { Tlbracket }
+  | ']'  { Trbracket }
+  | '*'  { Tstar }
+  | '?'  { Tmaybe }
+  | '+'  { Tplus }
+  | '('  { Tlparen }
+  | ')'  { Trparen }
+  | '^'  { Tcaret }
+  | '-'  { Tdash }
+  | eof
+    { raise(Lexical_error "unterminated lexer definition") }
+  | _
+    { raise(Lexical_error("illegal character " ^ lexing.lexeme lexbuf)) }
+
+and action = parse
+    '{' 
+    { brace_depth := brace_depth + 1;
+      action lexbuf }
+  | '}' 
+    { brace_depth := brace_depth - 1;
+      if brace_depth = 0 then lexing.lexeme_start lexbuf else action lexbuf }
+  | '"' 
+    { reset_string_buffer();
+      string lexbuf;
+      reset_string_buffer();
+      action lexbuf }
+  | '\''
+    { char lexbuf; action lexbuf }
+  | "(*" 
+    { comment_depth := 1;
+      comment lexbuf;
+      action lexbuf }
+  | eof 
+    { raise (Lexical_error "unterminated action") }
+  | _ 
+    { action lexbuf }
+      
+and string = parse
+    '"' 
+    { () }
+  | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] +
+    { string lexbuf }
+  | '\\' ['\\' '"' 'n' 't' 'b' 'r'] 
+    { store_string_char(char_for_backslash(lexing.lexeme_char lexbuf 1));
+      string lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] 
+    { store_string_char(char_for_decimal_code lexbuf 1);
+      string lexbuf }
+  | eof 
+    { raise(Lexical_error "unterminated string") }
+  | _ 
+    { store_string_char(lexing.lexeme_char lexbuf 0);
+      string lexbuf }
+
+and char = parse
+    [^ '\\'] "'" 
+    { lexing.lexeme_char lexbuf 0 }
+  | '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" 
+    { char_for_backslash (lexing.lexeme_char lexbuf 1) }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" 
+    { char_for_decimal_code lexbuf 1 }
+  | _ 
+    { raise(Lexical_error "bad character constant") }
+
+and comment = parse
+    "(*" 
+    { comment_depth := comment_depth + 1; comment lexbuf }
+  | "*)" 
+    { comment_depth := comment_depth - 1;
+      if comment_depth = 0 then () else comment lexbuf }
+  | '"' 
+    { reset_string_buffer();
+      string lexbuf;
+      reset_string_buffer();
+      comment lexbuf }
+  | eof 
+    { raise(Lexical_error "unterminated comment") }
+  | _ 
+    { comment lexbuf }
+;;
diff --git a/test/Makefile b/test/Makefile
new file mode 100644
index 00000000..2eea709f
--- /dev/null
+++ b/test/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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+# $Id: Makefile,v 1.31 2003/02/25 15:50:44 xleroy Exp $
+
+include ../config/Makefile
+
+CAMLC=../boot/ocamlrun ../ocamlc
+CAMLOPT=../boot/ocamlrun ../ocamlopt
+COMPFLAGS=-nostdlib -I ../stdlib -I KB -I Lex
+OPTFLAGS=-S
+CAMLYACC=../yacc/ocamlyacc
+YACCFLAGS=-v
+CAMLLEX=../boot/ocamlrun ../lex/ocamllex
+CAMLDEP=../boot/ocamlrun ../tools/ocamldep
+CAMLRUN=../byterun/ocamlrun
+CODERUNPARAMS=OCAMLRUNPARAM='o=100'
+
+BYTE_EXE=fib.byt takc.byt taku.byt sieve.byt quicksort.byt quicksort.fast.byt \
+  fft.byt fft.fast.byt soli.byt soli.fast.byt boyer.byt kb.byt \
+  nucleic.byt genlex.byt bdd.byt hamming.byt sorts.byt \
+  almabench.byt almabench.fast.byt
+
+CODE_EXE=$(BYTE_EXE:.byt=.out)
+
+default: all codetest bytetest
+
+all: $(BYTE_EXE) $(CODE_EXE)
+
+# Nucleic
+
+nucleic.out: nucleic.ml
+	case $(ARCH) in \
+          i386) sed -e '/<HAND_CSE>/,/<\/HAND_CSE>/d' -e '/NO_CSE>/d' \
+                nucleic.ml > nucleic.mlt; \
+	        $(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) -o nucleic.out nucleic.mlt;\
+	        rm -f nucleic.mlt;; \
+             *) $(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) -o nucleic.out nucleic.ml; \
+        esac
+
+# KB
+
+BYTE_KB=KB/terms.cmo KB/equations.cmo KB/kb.cmo KB/orderings.cmo KB/kbmain.cmo
+CODE_KB=$(BYTE_KB:.cmo=.cmx)
+
+kb.byt: $(BYTE_KB)
+	$(CAMLC) $(COMPFLAGS) $(BYTE_KB) -o kb.byt
+kb.out: $(CODE_KB)
+	$(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) $(CODE_KB) -o kb.out
+
+clean::
+	rm -f KB/*.cm[iox] KB/*.[os]
+	rm -f KB/*~
+
+# Genlex
+
+BYTE_GENLEX=Lex/syntax.cmo Lex/scan_aux.cmo Lex/scanner.cmo Lex/gram_aux.cmo \
+  Lex/grammar.cmo Lex/lexgen.cmo Lex/output.cmo Lex/main.cmo
+CODE_GENLEX=$(BYTE_GENLEX:.cmo=.cmx)
+
+genlex.byt: $(BYTE_GENLEX)
+	$(CAMLC) $(COMPFLAGS) $(BYTE_GENLEX) -o genlex.byt
+genlex.out: $(CODE_GENLEX)
+	$(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) $(CODE_GENLEX) -o genlex.out
+
+clean::
+	rm -f Lex/*.cm[iox] Lex/*.[os]
+	rm -f Lex/*~
+	rm -f Lex/grammar.output
+
+Lex/grammar.ml Lex/grammar.mli: Lex/grammar.mly ../yacc/ocamlyacc$(EXE)
+	$(CAMLYACC) $(YACCFLAGS) Lex/grammar.mly
+
+clean::
+	rm -f Lex/grammar.ml Lex/grammar.mli
+beforedepend:: Lex/grammar.ml Lex/grammar.mli
+
+Lex/scanner.ml: Lex/scanner.mll ../lex/ocamllex
+	$(CAMLLEX) Lex/scanner.mll
+
+clean::
+	rm -f Lex/scanner.ml
+beforedepend:: Lex/scanner.ml
+
+# Common rules
+
+.SUFFIXES:
+.SUFFIXES: .mli .ml .cmi .cmo .cmx .byt .fast.byt .out .fast.out
+
+.ml.byt:
+	$(CAMLC) $(COMPFLAGS) -o $*.byt $<
+
+.ml.fast.byt:
+	cp $*.ml $*_fast.ml
+	$(CAMLC) $(COMPFLAGS) -unsafe -o $*.fast.byt $*_fast.ml
+	rm -f $*_fast.ml
+
+.ml.out:
+	$(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) -o $*.out $<
+
+.ml.fast.out:
+	cp $*.ml $*_fast.ml
+	$(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) -unsafe -o $*.fast.out $*_fast.ml
+	rm -f $*_fast.ml
+
+.mli.cmi:
+	$(CAMLC) $(COMPFLAGS) -c $<
+
+.ml.cmo:
+	$(CAMLC) $(COMPFLAGS) -c $<
+
+.ml.cmx:
+	$(CAMLOPT) $(COMPFLAGS) $(OPTFLAGS) -c $<
+
+$(BYTE_EXE) $(BYTE_KB) $(BYTE_GENLEX): ../ocamlc
+$(BYTE_EXE): ../stdlib/stdlib.cma
+$(CODE_EXE) $(CODE_KB) $(CODE_GENLEX): ../ocamlopt
+$(CODE_EXE): ../stdlib/stdlib.cmxa ../stdlib/libasmrun.a
+
+clean::
+	rm -f *.byt *.out
+	rm -f *.cm[iox] *.[os]
+	rm -f *~
+
+# Regression test
+
+test: codetest
+
+bytetest:
+	set -e; \
+        for prog in $(BYTE_EXE:.byt=); do \
+          echo $$prog; \
+          if test -f Results/$$prog.runtest; then \
+            sh Results/$$prog.runtest test $(CAMLRUN) $$prog.byt; \
+          else \
+            $(CAMLRUN) $$prog.byt | cmp - Results/$$prog.out; \
+          fi; \
+        done
+
+codetest:
+	set -e; \
+        for prog in $(CODE_EXE:.out=); do \
+          echo $$prog; \
+          if test -f Results/$$prog.runtest; then \
+            sh Results/$$prog.runtest test ./$$prog.out; \
+          else \
+            ./$$prog.out | cmp - Results/$$prog.out; \
+          fi; \
+        done
+
+clean::
+	rm -f Lex/testscanner.ml
+
+# Benchmark
+
+bench: codebench
+
+bytebench:
+	set -e; \
+        for prog in $(BYTE_EXE:.byt=); do \
+          echo "$$prog                " | cut -c 1-16 | tr -d '\012'; \
+          if test -f Results/$$prog.runtest; then \
+            sh Results/$$prog.runtest bench $(CAMLRUN) $$prog.byt; \
+          else \
+            xtime -o /dev/null -e /dev/null $(CAMLRUN) $$prog.byt; \
+          fi; \
+        done
+
+codebench:
+	set -e; \
+        for prog in $(CODE_EXE:.out=); do \
+          echo "$$prog                " | cut -c 1-16 | tr -d '\012'; \
+          if test -f Results/$$prog.runtest; then \
+            $(CODERUNPARAMS) sh Results/$$prog.runtest bench ./$$prog.out; \
+          else \
+            $(CODERUNPARAMS) xtime -repeat 3 -o /dev/null -e /dev/null ./$$prog.out; \
+          fi; \
+        done
+
+# Dependencies
+
+depend: beforedepend
+	$(CAMLDEP) -I KB -I Lex *.mli *.ml KB/*.mli KB/*.ml Lex/*.mli Lex/*.ml > .depend
+
+include .depend
+
diff --git a/test/Moretest/.cvsignore b/test/Moretest/.cvsignore
new file mode 100644
index 00000000..55c27ce0
--- /dev/null
+++ b/test/Moretest/.cvsignore
@@ -0,0 +1,2 @@
+*.out
+*.byt
diff --git a/test/Moretest/.depend b/test/Moretest/.depend
new file mode 100644
index 00000000..e749398f
--- /dev/null
+++ b/test/Moretest/.depend
@@ -0,0 +1,6 @@
+multdef.cmo: multdef.cmi 
+multdef.cmx: multdef.cmi 
+structinit2.cmo: structinit1.cmo 
+structinit2.cmx: structinit1.cmx 
+usemultdef.cmo: multdef.cmi 
+usemultdef.cmx: multdef.cmx 
diff --git a/test/Moretest/Makefile b/test/Moretest/Makefile
new file mode 100644
index 00000000..1df9a28d
--- /dev/null
+++ b/test/Moretest/Makefile
@@ -0,0 +1,177 @@
+#########################################################################
+#                                                                       #
+#                            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.30 2003/04/25 12:27:31 xleroy Exp $
+
+include ../../config/Makefile
+
+CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib
+CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib
+OPTFLAGS=-S
+CAMLDEP=../../boot/ocamlrun ../../tools/ocamldep
+CAMLRUN=../../byterun/ocamlrun
+CODERUNPARAMS=OCAMLRUNPARAM='o=100'
+
+callback.byt: callback.cmo callbackprim.o
+	$(CAMLC) -o callback.byt -custom callback.cmo callbackprim.o ../../otherlibs/unix/libunix.a
+callback.out: callback.cmx callbackprim.o
+	$(CAMLOPT) -o callback.out callback.cmx callbackprim.o ../../otherlibs/unix/libunix.a
+
+manyargs.byt: manyargs.cmo manyargsprim.o
+	$(CAMLC) -o manyargs.byt -custom manyargs.cmo manyargsprim.o
+manyargs.out: manyargs.cmx manyargsprim.o
+	$(CAMLOPT) -o manyargs.out manyargs.cmx manyargsprim.o
+
+multdef.out: multdef.cmx usemultdef.cmx
+	$(CAMLOPT) -o multdef.out multdef.cmx usemultdef.cmx
+
+cm.byt: cmcaml.ml cmstub.c cmmain.c
+	$(CAMLC) -custom -o cm.byt cmcaml.ml cmstub.c cmmain.c
+
+cmlinked.out: cmcaml.ml cmstub.c cmmain.c
+	$(CAMLC) -output-obj -o cm.o cmcaml.ml
+	$(BYTECC) -g -o cmlinked.out cm.o -I../../byterun -DNO_BYTECODE_FILE cmstub.c cmmain.c ../../byterun/libcamlrun.a $(BYTECCLIBS)
+
+cm.out: cmcaml.ml cmstub.c cmmain.c
+	$(CAMLOPT) -output-obj -o cm.o cmcaml.ml
+	$(NATIVECC) -g -o cm.out cm.o -I$(LIBDIR) -DNO_BYTECODE_FILE cmstub.c cmmain.c ../../asmrun/libasmrun.a $(NATIVECCLIBS)
+
+bigarrays.byt: ../../otherlibs/bigarray/bigarray.cma \
+               ../../otherlibs/bigarray/libbigarray.a bigarrays.ml
+	$(CAMLC) -custom -o bigarrays.byt \
+                -I ../../otherlibs/bigarray \
+                -I ../../otherlibs/unix \
+                unix.cma bigarray.cma bigarrays.ml
+
+bigarrays.out: ../../otherlibs/bigarray/bigarray.cmxa \
+               ../../otherlibs/bigarray/libbigarray.a bigarrays.ml
+	$(CAMLOPT) $(OPTFLAGS) -o bigarrays.out \
+                -I ../../otherlibs/bigarray \
+                -I ../../otherlibs/unix \
+                unix.cmxa bigarray.cmxa bigarrays.ml
+
+bigarrf.byt: bigarrf.o bigarrfstub.o \
+               ../../otherlibs/bigarray/bigarray.cma \
+               ../../otherlibs/bigarray/libbigarray.a bigarrfml.ml
+	$(CAMLC) -custom -o bigarrf.byt \
+                -I ../../otherlibs/bigarray \
+                -I ../../otherlibs/unix \
+                unix.cma bigarray.cma bigarrf.ml \
+                bigarrf.o bigarrfstub.o \
+                ../../byterun/libcamlrun.a -cclib -lg2c
+
+bigarrf.out: bigarrf.o bigarrfstub.o \
+               ../../otherlibs/bigarray/bigarray.cma \
+               ../../otherlibs/bigarray/libbigarray.a bigarrfml.ml
+	$(CAMLOPT) $(OPTFLAGS) -o bigarrf.out \
+                -I ../../otherlibs/bigarray \
+                -I ../../otherlibs/unix \
+                unix.cma bigarray.cma bigarrf.ml \
+                bigarrf.o bigarrfstub.o \
+                ../../byterun/libcamlrun.a -cclib -lg2c
+
+bigarrf.o: bigarrf.f
+	g77 -c bigarrf.f
+
+bigarrfstub.o: bigarrfstub.c
+	$(NATIVECC) $(NATIVECCCOMPOPTS) -I../../byterun -I../../otherlibs/bigarray -c bigarrfstub.c
+
+fftba.byt: fftba.ml
+	$(CAMLC) -o fftba.byt -I ../../otherlibs/bigarray \
+          bigarray.cma fftba.ml
+
+fftba.out: fftba.ml
+	$(CAMLOPT) $(OPTFLAGS) -o fftba.out -I ../../otherlibs/bigarray \
+          bigarray.cmxa fftba.ml
+
+globroots.byt: globroots.ml globrootsprim.o
+	$(CAMLC) -custom -o globroots.byt globroots.ml globrootsprim.o
+
+globroots.out: globroots.ml globrootsprim.o
+	$(CAMLOPT) -o globroots.out globroots.ml globrootsprim.o
+
+globrootsprim.o: globrootsprim.c
+	$(BYTECC) $(BYTECCCOMPOPTS) -I../../byterun -c globrootsprim.c
+
+float.byt: float.cmo
+	${CAMLC} -o float.byt float.cmo
+float.out: float.cmx
+	${CAMLOPT} -o float.out float.cmx
+
+intext.byt: intext.cmo intextaux.o
+	${CAMLC} -o intext.byt -custom intext.cmo intextaux.o
+intext.out: intext.cmx intextaux.o
+	${CAMLOPT} -o intext.out intext.cmx intextaux.o
+
+tscanf.byt: tscanf.cmo
+	${CAMLC} -o tscanf.byt tscanf.cmo
+tscanf.out: tscanf.cmx
+	${CAMLOPT} -o tscanf.out tscanf.cmx
+
+scanf: tscanf.byt tscanf.out
+	./tscanf.byt
+	./tscanf.out
+
+regexp.byt: ../../otherlibs/str/str.cma regexp.ml
+	$(CAMLC) -custom -I ../../otherlibs/str -o regexp.byt str.cma regexp.ml
+regexp.opt: ../../otherlibs/str/str.cmxa regexp.ml
+	$(CAMLOPT) -I ../../otherlibs/str -o regexp.opt str.cmxa regexp.ml
+
+md5.out: md5.ml
+	$(CAMLOPT) -unsafe -inline 100 -o md5.out md5.ml
+
+# Common rules
+
+.SUFFIXES:
+.SUFFIXES: .mli .ml .cmi .cmo .cmx .byt .fast.byt .out .fast.out .c .o
+
+.ml.byt:
+	$(CAMLC) -o $*.byt $<
+
+.ml.fast.byt:
+	cp $*.ml $*_fast.ml
+	$(CAMLC) -unsafe -o $*.fast.byt $*_fast.ml
+	rm -f $*_fast.ml
+
+.ml.out:
+	$(CAMLOPT) $(OPTFLAGS) -o $*.out $<
+
+.ml.fast.out:
+	cp $*.ml $*_fast.ml
+	$(CAMLOPT) $(OPTFLAGS) -unsafe -o $*.fast.out $*_fast.ml
+	rm -f $*_fast.ml
+
+.mli.cmi:
+	$(CAMLC) -c $<
+
+.ml.cmo:
+	$(CAMLC) -c $<
+
+.ml.cmx:
+	$(CAMLOPT) $(OPTFLAGS) -c $<
+
+.c.o:
+	$(NATIVECC) $(NATIVECCCOMPOPTS) -I../../byterun -c $<
+
+clean::
+	rm -f *.byt *.out
+	rm -f *.cm[iox] *.[os]
+	rm -f *~
+	rm -f intext.data
+
+# Dependencies
+
+depend:
+	$(CAMLDEP) *.mli *.ml > .depend
+
+include .depend
+
diff --git a/test/Moretest/arrays.ml b/test/Moretest/arrays.ml
new file mode 100644
index 00000000..bbe8be32
--- /dev/null
+++ b/test/Moretest/arrays.ml
@@ -0,0 +1,86 @@
+let bigarray n = [|
+n+0; n+1; n+2; n+3; n+4; n+5; n+6; n+7; n+8; n+9; n+10; n+11; n+12;
+n+13; n+14; n+15; n+16; n+17; n+18; n+19; n+20; n+21; n+22; n+23;
+n+24; n+25; n+26; n+27; n+28; n+29; n+30; n+31; n+32; n+33; n+34;
+n+35; n+36; n+37; n+38; n+39; n+40; n+41; n+42; n+43; n+44; n+45;
+n+46; n+47; n+48; n+49; n+50; n+51; n+52; n+53; n+54; n+55; n+56;
+n+57; n+58; n+59; n+60; n+61; n+62; n+63; n+64; n+65; n+66; n+67;
+n+68; n+69; n+70; n+71; n+72; n+73; n+74; n+75; n+76; n+77; n+78;
+n+79; n+80; n+81; n+82; n+83; n+84; n+85; n+86; n+87; n+88; n+89;
+n+90; n+91; n+92; n+93; n+94; n+95; n+96; n+97; n+98; n+99; n+100;
+n+101; n+102; n+103; n+104; n+105; n+106; n+107; n+108; n+109; n+110;
+n+111; n+112; n+113; n+114; n+115; n+116; n+117; n+118; n+119; n+120;
+n+121; n+122; n+123; n+124; n+125; n+126; n+127; n+128; n+129; n+130;
+n+131; n+132; n+133; n+134; n+135; n+136; n+137; n+138; n+139; n+140;
+n+141; n+142; n+143; n+144; n+145; n+146; n+147; n+148; n+149; n+150;
+n+151; n+152; n+153; n+154; n+155; n+156; n+157; n+158; n+159; n+160;
+n+161; n+162; n+163; n+164; n+165; n+166; n+167; n+168; n+169; n+170;
+n+171; n+172; n+173; n+174; n+175; n+176; n+177; n+178; n+179; n+180;
+n+181; n+182; n+183; n+184; n+185; n+186; n+187; n+188; n+189; n+190;
+n+191; n+192; n+193; n+194; n+195; n+196; n+197; n+198; n+199; n+200;
+n+201; n+202; n+203; n+204; n+205; n+206; n+207; n+208; n+209; n+210;
+n+211; n+212; n+213; n+214; n+215; n+216; n+217; n+218; n+219; n+220;
+n+221; n+222; n+223; n+224; n+225; n+226; n+227; n+228; n+229; n+230;
+n+231; n+232; n+233; n+234; n+235; n+236; n+237; n+238; n+239; n+240;
+n+241; n+242; n+243; n+244; n+245; n+246; n+247; n+248; n+249; n+250;
+n+251; n+252; n+253; n+254; n+255; n+256; n+257; n+258; n+259; n+260;
+n+261; n+262; n+263; n+264; n+265; n+266; n+267; n+268; n+269; n+270;
+n+271; n+272; n+273; n+274; n+275; n+276; n+277; n+278; n+279; n+280;
+n+281; n+282; n+283; n+284; n+285; n+286; n+287; n+288; n+289; n+290;
+n+291; n+292; n+293; n+294; n+295; n+296; n+297; n+298; n+299
+|]
+
+let test1 () =
+  let a = bigarray 12345 in
+  Gc.full_major();
+  for i = 0 to Array.length a - 1 do
+    if a.(i) <> 12345 + i then print_string "Test1: error\n"
+  done
+
+let testcopy a =
+  Array.copy a = a
+
+let test2 () =
+  if not (testcopy [|1;2;3;4;5|]) then
+    print_string "Test2: failed on int array\n";
+  if not (testcopy [|1.2;2.3;3.4;4.5|]) then
+    print_string "Test2: failed on float array\n";
+  if not (testcopy [|"un"; "deux"; "trois"|]) then
+    print_string "Test2: failed on string array\n"
+
+module AbstractFloat =
+  (struct
+    type t = float
+    let to_float x = x
+    let from_float x = x
+   end :
+   sig
+    type t
+    val to_float: t -> float
+    val from_float: float -> t
+   end)
+
+let test3 () =
+  let t1 = AbstractFloat.from_float 1.0
+  and t2 = AbstractFloat.from_float 2.0
+  and t3 = AbstractFloat.from_float 3.0 in
+  let v = [|t1;t2;t3|] in
+  let w = Array.create 2 t1 in
+  let u = Array.copy v in
+  if not (AbstractFloat.to_float v.(0) = 1.0 &&
+          AbstractFloat.to_float v.(1) = 2.0 &&
+          AbstractFloat.to_float v.(2) = 3.0) then
+    print_string "Test3: failed on v\n";
+  if not (AbstractFloat.to_float w.(0) = 1.0 &&
+          AbstractFloat.to_float w.(1) = 1.0) then
+    print_string "Test3: failed on w\n";
+  if not (AbstractFloat.to_float u.(0) = 1.0 &&
+          AbstractFloat.to_float u.(1) = 2.0 &&
+          AbstractFloat.to_float u.(2) = 3.0) then
+    print_string "Test3: failed on u\n"
+
+let _ =
+  test1();
+  test2();
+  test3();
+  exit 0
diff --git a/test/Moretest/bigarrays.ml b/test/Moretest/bigarrays.ml
new file mode 100644
index 00000000..302ade99
--- /dev/null
+++ b/test/Moretest/bigarrays.ml
@@ -0,0 +1,720 @@
+open Bigarray
+open Printf
+open Complex
+
+(* Test harness *)
+
+let error_occurred = ref false
+
+let function_tested = ref ""
+
+let testing_function s =
+    function_tested := s;
+    print_newline();
+    print_string s;
+    print_newline()
+
+let test test_number answer correct_answer =
+ flush stdout;
+ flush stderr;
+ if answer <> correct_answer then begin
+   eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number;
+   flush stderr;
+   error_occurred := true
+ end else begin
+   printf " %d..." test_number
+ end
+
+(* One-dimensional arrays *)
+
+let _ =
+  testing_function "------ Array1 --------";
+  testing_function "create/set/get";
+  let test_setget kind vals =
+    let rec set a i = function
+        [] -> ()
+      | (v1, v2) :: tl -> a.{i} <- v1; set a (i+1) tl in
+    let rec test a i = function
+        [] -> true
+      | (v1, v2) :: tl -> a.{i} = v2 && test a (i+1) tl in
+    let ca = Array1.create kind c_layout (List.length vals) in
+    let fa = Array1.create kind fortran_layout (List.length vals) in
+    set ca 0 vals;
+    set fa 1 vals;
+    test ca 0 vals && test fa 1 vals in
+  test 1 true
+    (test_setget int8_signed
+                 [0, 0;
+                  123, 123;
+                  -123, -123;
+                  456, -56;
+                  0x101, 1]);
+  test 2 true
+    (test_setget int8_unsigned
+                 [0, 0;
+                  123, 123;
+                  -123, 133;
+                  456, 0xc8;
+                  0x101, 1]);
+  test 3 true
+    (test_setget int16_signed
+                 [0, 0;
+                  123, 123;
+                  -123, -123;
+                  31456, 31456;
+                  -31456, -31456;
+                  65432, -104;
+                  0x10001, 1]);
+  test 4 true
+    (test_setget int16_unsigned
+                 [0, 0;
+                  123, 123;
+                  -123, 65413;
+                  31456, 31456;
+                  -31456, 34080;
+                  65432, 65432;
+                  0x10001, 1]);
+  test 5 true
+    (test_setget int
+                 [0, 0;
+                  123, 123;
+                  -456, -456;
+                  max_int, max_int;
+                  min_int, min_int;
+                  0x12345678, 0x12345678;
+                  -0x12345678, -0x12345678]);
+  test 6 true
+    (test_setget int32
+                 [Int32.zero, Int32.zero;
+                  Int32.of_int 123, Int32.of_int 123;
+                  Int32.of_int (-456), Int32.of_int (-456);
+                  Int32.max_int, Int32.max_int;
+                  Int32.min_int, Int32.min_int;
+                  Int32.of_string "0x12345678", Int32.of_string "0x12345678"]);
+  test 7 true
+    (test_setget int64
+                 [Int64.zero, Int64.zero;
+                  Int64.of_int 123, Int64.of_int 123;
+                  Int64.of_int (-456), Int64.of_int (-456);
+                  Int64.max_int, Int64.max_int;
+                  Int64.min_int, Int64.min_int;
+                  Int64.of_string "0x123456789ABCDEF0",
+                     Int64.of_string "0x123456789ABCDEF0"]);
+  test 8 true
+    (test_setget nativeint
+                 [Nativeint.zero, Nativeint.zero;
+                  Nativeint.of_int 123, Nativeint.of_int 123;
+                  Nativeint.of_int (-456), Nativeint.of_int (-456);
+                  Nativeint.max_int, Nativeint.max_int;
+                  Nativeint.min_int, Nativeint.min_int;
+                  Nativeint.of_string "0x12345678",
+                    Nativeint.of_string "0x12345678"]);
+  test 9 true
+    (test_setget float32
+                 [0.0, 0.0;
+                  4.0, 4.0;
+                  -0.5, -0.5;
+                  655360.0, 655360.0]);
+  test 10 true
+    (test_setget float64
+                 [0.0, 0.0;
+                  4.0, 4.0;
+                  -0.5, -0.5;
+                  1.2345678, 1.2345678;
+                  3.1415e10, 3.1415e10]);
+  test 11 true
+    (test_setget complex32
+                 [Complex.zero, Complex.zero;
+                  Complex.one, Complex.one;
+                  Complex.i, Complex.i;
+                  {im = 0.5; re = -2.0}, {im = 0.5; re = -2.0}]);
+  test 12 true
+    (test_setget complex64
+                 [Complex.zero, Complex.zero;
+                  Complex.one, Complex.one;
+                  Complex.i, Complex.i;
+                  {im=0.5;re= -2.0}, {im=0.5;re= -2.0};
+                  {im=3.1415;re=1.2345678}, {im=3.1415;re=1.2345678}]);
+
+  let from_list kind vals =
+    let a = Array1.create kind c_layout (List.length vals) in
+    let rec set i = function
+        [] -> () 
+      | hd :: tl -> a.{i} <- hd; set (i+1) tl in
+    set 0 vals;
+    a in
+  let from_list_fortran kind vals =
+    let a = Array1.create kind fortran_layout (List.length vals) in
+    let rec set i = function
+        [] -> () 
+      | hd :: tl -> a.{i} <- hd; set (i+1) tl in
+    set 1 vals;
+    a in
+
+  testing_function "set/get (specialized)";
+  let a = Array1.create int c_layout 3 in
+  for i = 0 to 2 do a.{i} <- i done;
+  for i = 0 to 2 do test (i+1) a.{i} i done;
+  test 4 true (try a.{3}; false with Invalid_argument _ -> true);
+  test 5 true (try a.{-1}; false with Invalid_argument _ -> true);
+    
+  let b = Array1.create float64 fortran_layout 3 in
+  for i = 1 to 3 do b.{i} <- float i done;
+  for i = 1 to 3 do test (5 + i) b.{i} (float i) done;
+  test 8 true (try b.{4}; false with Invalid_argument _ -> true);
+  test 9 true (try b.{0}; false with Invalid_argument _ -> true);
+
+  let c = Array1.create complex64 c_layout 3 in
+  for i = 0 to 2 do c.{i} <- {re=float i; im=0.0} done;
+  for i = 0 to 2 do test (10 + i) c.{i} {re=float i; im=0.0} done;
+  test 13 true (try c.{3}; false with Invalid_argument _ -> true);
+  test 14 true (try c.{-1}; false with Invalid_argument _ -> true);
+
+  let d = Array1.create complex32 fortran_layout 3 in
+  for i = 1 to 3 do d.{i} <- {re=float i; im=0.0} done;
+  for i = 1 to 3 do test (14 + i) d.{i} {re=float i; im=0.0} done;
+  test 18 true (try d.{4}; false with Invalid_argument _ -> true);
+  test 19 true (try d.{0}; false with Invalid_argument _ -> true);
+
+  testing_function "comparisons";
+  let normalize_comparison n =
+    if n = 0 then 0 else if n < 0 then -1 else 1 in
+  test 1 0 (normalize_comparison (compare
+     (from_list int8_signed [1;2;3;-4;127;-128])
+     (from_list int8_signed [1;2;3;-4;127;-128])));
+  test 2 (-1) (normalize_comparison (compare
+     (from_list int8_signed [1;2;3;-4;127;-128])
+     (from_list int8_signed [1;2;3;4;127;-128])));
+  test 3 1 (normalize_comparison (compare
+     (from_list int8_signed [1;2;3;-4;127;-128])
+     (from_list int8_signed [1;2;3;-4;42;-128])));
+  test 4 (-1) (normalize_comparison (compare
+     (from_list int8_signed [1;2;3;-4])
+     (from_list int8_signed [1;2;3;4;127;-128])));
+  test 5 1 (normalize_comparison (compare
+     (from_list int8_signed [1;2;3;4;127;-128])
+     (from_list int8_signed [1;2;3;-4])));
+
+  test 6 0 (normalize_comparison (compare
+     (from_list int8_unsigned [1;2;3;-4;127;-128])
+     (from_list int8_unsigned [1;2;3;-4;127;-128])));
+  test 7 1 (normalize_comparison (compare
+     (from_list int8_unsigned [1;2;3;-4;127;-128])
+     (from_list int8_unsigned [1;2;3;4;127;-128])));
+  test 8 1 (normalize_comparison (compare
+     (from_list int8_unsigned [1;2;3;-4;127;-128])
+     (from_list int8_unsigned [1;2;3;-4;42;-128])));
+
+  test 9 0 (normalize_comparison (compare
+     (from_list int16_signed [1;2;3;-4;127;-128])
+     (from_list int16_signed [1;2;3;-4;127;-128])));
+  test 10 (-1) (normalize_comparison (compare
+     (from_list int16_signed [1;2;3;-4;127;-128])
+     (from_list int16_signed [1;2;3;4;127;-128])));
+  test 11 1 (normalize_comparison (compare
+     (from_list int16_signed [1;2;3;-4;127;-128])
+     (from_list int16_signed [1;2;3;-4;42;-128])));
+
+  test 12 0 (normalize_comparison (compare
+     (from_list int16_unsigned [1;2;3;-4;127;-128])
+     (from_list int16_unsigned [1;2;3;-4;127;-128])));
+  test 13 (-1) (normalize_comparison (compare
+     (from_list int16_unsigned [1;2;3;4;127;-128])
+     (from_list int16_unsigned [1;2;3;0xFFFF;127;-128])));
+  test 14 1 (normalize_comparison (compare
+     (from_list int16_unsigned [1;2;3;-4;127;-128])
+     (from_list int16_unsigned [1;2;3;-4;42;-128])));
+
+  test 15 0 (normalize_comparison (compare
+     (from_list int [1;2;3;-4;127;-128])
+     (from_list int [1;2;3;-4;127;-128])));
+  test 16 (-1) (normalize_comparison (compare
+     (from_list int [1;2;3;-4;127;-128])
+     (from_list int [1;2;3;4;127;-128])));
+  test 17 1 (normalize_comparison (compare
+     (from_list int [1;2;3;-4;127;-128])
+     (from_list int [1;2;3;-4;42;-128])));
+
+  test 18 0 (normalize_comparison (compare
+     (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128]))
+     (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128]))));
+  test 19 (-1) (normalize_comparison (compare
+     (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128]))
+     (from_list int32 (List.map Int32.of_int [1;2;3;4;127;-128]))));
+  test 20 1 (normalize_comparison (compare
+     (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128]))
+     (from_list int32 (List.map Int32.of_int [1;2;3;-4;42;-128]))));
+
+  test 21 0 (normalize_comparison (compare
+     (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128]))
+     (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128]))));
+  test 22 (-1) (normalize_comparison (compare
+     (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128]))
+     (from_list int64 (List.map Int64.of_int [1;2;3;4;127;-128]))));
+  test 23 1 (normalize_comparison (compare
+     (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128]))
+     (from_list int64 (List.map Int64.of_int [1;2;3;-4;42;-128]))));
+
+  test 24 0 (normalize_comparison (compare
+     (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128]))
+     (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128]))));
+  test 25 (-1) (normalize_comparison (compare
+     (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128]))
+     (from_list nativeint (List.map Nativeint.of_int [1;2;3;4;127;-128]))));
+  test 26 1 (normalize_comparison (compare
+     (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128]))
+     (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;42;-128]))));
+
+  test 27 0 (normalize_comparison (compare
+     (from_list float32 [0.0; 0.25; -4.0; 3.141592654])
+     (from_list float32 [0.0; 0.25; -4.0; 3.141592654])));
+  test 28 (-1) (normalize_comparison (compare
+     (from_list float32 [0.0; 0.25; -4.0])
+     (from_list float32 [0.0; 0.25; 3.14159])));
+  test 29 1 (normalize_comparison (compare
+     (from_list float32 [0.0; 2.718; -4.0])
+     (from_list float32 [0.0; 0.25; 3.14159])));
+
+  test 30 0 (normalize_comparison (compare
+     (from_list float64 [0.0; 0.25; -4.0; 3.141592654])
+     (from_list float64 [0.0; 0.25; -4.0; 3.141592654])));
+  test 31 (-1) (normalize_comparison (compare
+     (from_list float64 [0.0; 0.25; -4.0])
+     (from_list float64 [0.0; 0.25; 3.14159])));
+  test 32 1 (normalize_comparison (compare
+     (from_list float64 [0.0; 2.718; -4.0])
+     (from_list float64 [0.0; 0.25; 3.14159])));
+
+  test 44 0 (normalize_comparison (compare
+     (from_list complex32 [Complex.zero; Complex.one; Complex.i])
+     (from_list complex32 [Complex.zero; Complex.one; Complex.i])));
+  test 45 (-1) (normalize_comparison (compare
+     (from_list complex32 [Complex.zero; Complex.one; Complex.i])
+     (from_list complex32 [Complex.zero; Complex.one; Complex.one])));
+  test 46 1 (normalize_comparison (compare
+     (from_list complex32 [Complex.zero; Complex.one; Complex.one])
+     (from_list complex32 [Complex.zero; Complex.one; Complex.i])));
+
+  test 47 0 (normalize_comparison (compare
+     (from_list complex64 [Complex.zero; Complex.one; Complex.i])
+     (from_list complex64 [Complex.zero; Complex.one; Complex.i])));
+  test 48 (-1) (normalize_comparison (compare
+     (from_list complex64 [Complex.zero; Complex.one; Complex.i])
+     (from_list complex64 [Complex.zero; Complex.one; Complex.one])));
+  test 49 1 (normalize_comparison (compare
+     (from_list complex64 [Complex.zero; Complex.one; Complex.one])
+     (from_list complex64 [Complex.zero; Complex.one; Complex.i])));
+
+  testing_function "dim";
+  test 1 (Array1.dim (from_list int [1;2;3;4;5])) 5;
+  test 2 (Array1.dim (from_list_fortran int [1;2;3])) 3;
+
+  testing_function "kind & layout";
+  let a = from_list int [1;2;3] in
+  test 1 (Array1.kind a) int;
+  test 2 (Array1.layout a) c_layout;
+  let a = from_list_fortran float32 [1.0;2.0;3.0] in
+  test 1 (Array1.kind a) float32;
+  test 2 (Array1.layout a) fortran_layout;
+
+  testing_function "sub";
+  let a = from_list int [1;2;3;4;5;6;7;8] in
+  test 1 (Array1.sub a 2 5)
+         (from_list int [3;4;5;6;7]);
+  test 2 (Array1.sub a 0 2)
+         (from_list int [1;2]);
+  test 3 (Array1.sub a 0 8)
+         (from_list int [1;2;3;4;5;6;7;8]);
+  let a = from_list float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0] in
+  test 4 (Array1.sub a 2 5)
+         (from_list float64 [3.0;4.0;5.0;6.0;7.0]);
+  test 5 (Array1.sub a 0 2)
+         (from_list float64 [1.0;2.0]);
+  test 6 (Array1.sub a 0 8)
+         (from_list float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0]);
+  let a = from_list_fortran float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0] in
+  test 7 (Array1.sub a 2 5)
+         (from_list_fortran float64 [2.0;3.0;4.0;5.0;6.0]);
+  test 8 (Array1.sub a 1 2)
+         (from_list_fortran float64 [1.0;2.0]);
+  test 9 (Array1.sub a 1 8)
+         (from_list_fortran float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0]);
+  Gc.full_major();  (* test GC of proxies *)
+
+  testing_function "blit, fill";
+  let test_blit_fill kind data initval ofs len =
+    let a = from_list kind data in
+    let b = Array1.create kind c_layout (List.length data) in
+    Array1.blit a b;
+    (a = b) &&
+    (Array1.fill (Array1.sub b ofs len) initval;
+     let rec check i = function
+         [] -> true
+       | hd :: tl -> b.{i} = (if i >= ofs && i < ofs + len
+                                       then initval else hd)
+                     && check (i+1) tl
+     in check 0 data) in
+  test 1 true (test_blit_fill int8_signed [1;2;5;8;-100;127] 7 3 2);
+  test 2 true (test_blit_fill int8_unsigned [1;2;5;8;-100;212] 7 3 2);
+  test 3 true (test_blit_fill int16_signed [1;2;5;8;-100;212] 7 3 2);
+  test 4 true (test_blit_fill int16_unsigned [1;2;5;8;-100;212] 7 3 2);
+  test 5 true (test_blit_fill int [1;2;5;8;-100;212] 7 3 2);
+  test 6 true (test_blit_fill int32 (List.map Int32.of_int [1;2;5;8;-100;212])
+                                    (Int32.of_int 7) 3 2);
+  test 7 true (test_blit_fill int64 (List.map Int64.of_int [1;2;5;8;-100;212])
+                                    (Int64.of_int 7) 3 2);
+  test 8 true (test_blit_fill nativeint
+                             (List.map Nativeint.of_int [1;2;5;8;-100;212])
+                             (Nativeint.of_int 7) 3 2);
+  test 9 true (test_blit_fill float32 [1.0;2.0;0.5;0.125;256.0;512.0]
+                             0.25 3 2);
+  test 10 true (test_blit_fill float64 [1.0;2.0;5.0;8.123;-100.456;212e19]
+                             3.1415 3 2);
+  test 11 true (test_blit_fill complex32 [Complex.zero; Complex.one; Complex.i]
+                             Complex.i 1 1);
+  test 12 true (test_blit_fill complex64 [Complex.zero; Complex.one; Complex.i]
+                             Complex.i 1 1);
+
+(* Bi-dimensional arrays *)
+
+  print_newline();
+  testing_function "------ Array2 --------";
+  testing_function "create/set/get";
+  let make_array2 kind layout ind0 dim1 dim2 fromint =
+    let a = Array2.create kind layout dim1 dim2 in
+    for i = ind0 to dim1 - 1 + ind0 do
+      for j = ind0 to dim2 - 1 + ind0 do
+        a.{i,j} <- (fromint (i * 1000 + j))
+      done
+    done;
+    a in
+  let check_array2 a ind0 dim1 dim2 fromint =
+    try
+      for i = ind0 to dim1 - 1 + ind0 do
+        for j = ind0 to dim2 - 1 + ind0 do
+          if a.{i,j} <> (fromint (i * 1000 + j)) then raise Exit
+        done
+      done;
+      true
+    with Exit -> false in
+  let id x = x in
+  test 1 true
+    (check_array2 (make_array2 int16_signed c_layout 0 10 20 id) 0 10 20 id);
+  test 2 true
+    (check_array2 (make_array2 int c_layout 0 10 20 id) 0 10 20 id);
+  test 3 true
+    (check_array2 (make_array2 int32 c_layout 0 10 20 Int32.of_int)
+                  0 10 20 Int32.of_int);
+  test 4 true
+    (check_array2 (make_array2 float32 c_layout 0 10 20 float)
+                  0 10 20 float);
+  test 5 true
+    (check_array2 (make_array2 float64 c_layout 0 10 20 float)
+                  0 10 20 float);
+  test 6 true
+    (check_array2 (make_array2 int16_signed fortran_layout 1 10 20 id) 1 10 20 id);
+  test 7 true
+    (check_array2 (make_array2 int fortran_layout 1 10 20 id) 1 10 20 id);
+  test 8 true
+    (check_array2 (make_array2 int32 fortran_layout 1 10 20 Int32.of_int)
+                  1 10 20 Int32.of_int);
+  test 9 true
+    (check_array2 (make_array2 float32 fortran_layout 1 10 20 float)
+                  1 10 20 float);
+  test 10 true
+    (check_array2 (make_array2 float64 fortran_layout 1 10 20 float)
+                  1 10 20 float);
+  let makecomplex i = {re = float i; im = float (-i)} in
+  test 11 true
+    (check_array2 (make_array2 complex32 c_layout 0 10 20 makecomplex)
+                  0 10 20 makecomplex);
+  test 12 true
+    (check_array2 (make_array2 complex64 c_layout 0 10 20 makecomplex)
+                  0 10 20 makecomplex);
+  test 13 true
+    (check_array2 (make_array2 complex32 fortran_layout 1 10 20 makecomplex)
+                  1 10 20 makecomplex);
+  test 14 true
+    (check_array2 (make_array2 complex64 fortran_layout 1 10 20 makecomplex)
+                  1 10 20 makecomplex);
+
+  testing_function "set/get (specialized)";
+  let a = Array2.create int16_signed c_layout 3 3 in
+  for i = 0 to 2 do for j = 0 to 2 do a.{i,j} <- i-j done done;
+  let ok = ref true in
+  for i = 0 to 2 do
+    for j = 0 to 2 do if a.{i,j} <> i-j then ok := false done
+  done;
+  test 1 true !ok;
+  test 2 true (try a.{3,0}; false with Invalid_argument _ -> true);
+  test 3 true (try a.{-1,0}; false with Invalid_argument _ -> true);
+  test 4 true (try a.{0,3}; false with Invalid_argument _ -> true);
+  test 5 true (try a.{0,-1}; false with Invalid_argument _ -> true);
+    
+  let b = Array2.create float32 fortran_layout 3 3 in
+  for i = 1 to 3 do for j = 1 to 3 do b.{i,j} <- float(i-j) done done;
+  let ok = ref true in
+  for i = 1 to 3 do
+    for j = 1 to 3 do if b.{i,j} <> float(i-j) then ok := false done
+  done;
+  test 6 true !ok;
+  test 7 true (try b.{4,1}; false with Invalid_argument _ -> true);
+  test 8 true (try b.{0,1}; false with Invalid_argument _ -> true);
+  test 9 true (try b.{1,4}; false with Invalid_argument _ -> true);
+  test 10 true (try b.{1,0}; false with Invalid_argument _ -> true);
+
+  testing_function "dim";
+  let a = (make_array2 int c_layout 0 4 6 id) in
+  test 1 (Array2.dim1 a) 4;
+  test 2 (Array2.dim2 a) 6;
+  let b =  (make_array2 int fortran_layout 1 4 6 id) in
+  test 3 (Array2.dim1 b) 4;
+  test 4 (Array2.dim2 b) 6;
+
+  testing_function "sub";
+  let a = make_array2 int c_layout 0 5 3 id in
+  let b = Array2.sub_left a 2 2 in
+  test 1 true
+         (b.{0,0} = 2000 &&
+          b.{0,1} = 2001 &&
+          b.{0,2} = 2002 &&
+          b.{1,0} = 3000 &&
+          b.{1,1} = 3001 &&
+          b.{1,2} = 3002);
+  let a = make_array2 int fortran_layout 1 5 3 id in
+  let b = Array2.sub_right a 2 2 in
+  test 2 true
+         (b.{1,1} = 1002 &&
+          b.{1,2} = 1003 &&
+          b.{2,1} = 2002 &&
+          b.{2,2} = 2003 &&
+          b.{3,1} = 3002 &&
+          b.{3,2} = 3003 &&
+          b.{4,1} = 4002 &&
+          b.{4,2} = 4003 &&
+          b.{5,1} = 5002 &&
+          b.{5,2} = 5003);
+
+  testing_function "slice";
+  let a = make_array2 int c_layout 0 5 3 id in
+  test 1 (Array2.slice_left a 0) (from_list int [0;1;2]);
+  test 2 (Array2.slice_left a 1) (from_list int [1000;1001;1002]);
+  test 3 (Array2.slice_left a 2) (from_list int [2000;2001;2002]);
+  test 4 (Array2.slice_left a 3) (from_list int [3000;3001;3002]);
+  test 5 (Array2.slice_left a 4) (from_list int [4000;4001;4002]);
+  let a = make_array2 int fortran_layout 1 5 3 id in
+  test 6 (Array2.slice_right a 1) (from_list_fortran int [1001;2001;3001;4001;5001]);
+  test 7 (Array2.slice_right a 2) (from_list_fortran int [1002;2002;3002;4002;5002]);
+  test 8 (Array2.slice_right a 3) (from_list_fortran int [1003;2003;3003;4003;5003]);
+
+(* Tri-dimensional arrays *)
+
+  print_newline();
+  testing_function "------ Array3 --------";
+  testing_function "create/set/get";
+  let make_array3 kind layout ind0 dim1 dim2 dim3 fromint =
+    let a = Array3.create kind layout dim1 dim2 dim3 in
+    for i = ind0 to dim1 - 1 + ind0 do
+      for j = ind0 to dim2 - 1 + ind0 do
+        for k = ind0 to dim3 - 1 + ind0 do
+          a.{i, j, k} <- (fromint (i * 100 + j * 10 + k))
+        done
+      done
+    done;
+    a in
+  let check_array3 a ind0 dim1 dim2 dim3 fromint =
+    try
+      for i = ind0 to dim1 - 1 + ind0 do
+        for j = ind0 to dim2 - 1 + ind0 do
+          for k = ind0 to dim3 - 1 + ind0 do
+            if a.{i, j, k} <> (fromint (i * 100 + j * 10 + k))
+            then raise Exit
+          done
+        done
+      done;
+      true
+    with Exit -> false in
+  let id x = x in
+  test 1 true
+    (check_array3 (make_array3 int16_signed c_layout 0 4 5 6 id) 0 4 5 6 id);
+  test 2 true
+    (check_array3 (make_array3 int c_layout 0 4 5 6 id) 0 4 5 6 id);
+  test 3 true
+    (check_array3 (make_array3 int32 c_layout 0 4 5 6 Int32.of_int)
+                  0 4 5 6 Int32.of_int);
+  test 4 true
+    (check_array3 (make_array3 float32 c_layout 0 4 5 6 float)
+                  0 4 5 6 float);
+  test 5 true
+    (check_array3 (make_array3 float64 c_layout 0 4 5 6 float)
+                  0 4 5 6 float);
+  test 6 true
+    (check_array3 (make_array3 int16_signed fortran_layout 1 4 5 6 id) 1 4 5 6 id);
+  test 7 true
+    (check_array3 (make_array3 int fortran_layout 1 4 5 6 id) 1 4 5 6 id);
+  test 8 true
+    (check_array3 (make_array3 int32 fortran_layout 1 4 5 6 Int32.of_int)
+                  1 4 5 6 Int32.of_int);
+  test 9 true
+    (check_array3 (make_array3 float32 fortran_layout 1 4 5 6 float)
+                  1 4 5 6 float);
+  test 10 true
+    (check_array3 (make_array3 float64 fortran_layout 1 4 5 6 float)
+                  1 4 5 6 float);
+  test 11 true
+    (check_array3 (make_array3 complex32 c_layout 0 4 5 6 makecomplex)
+                  0 4 5 6 makecomplex);
+  test 12 true
+    (check_array3 (make_array3 complex64 c_layout 0 4 5 6 makecomplex)
+                  0 4 5 6 makecomplex);
+  test 13 true
+    (check_array3 (make_array3 complex32 fortran_layout 1 4 5 6 makecomplex)
+                  1 4 5 6 makecomplex);
+  test 14 true
+    (check_array3 (make_array3 complex64 fortran_layout 1 4 5 6 makecomplex)
+                  1 4 5 6 makecomplex);
+
+
+  testing_function "set/get (specialized)";
+  let a = Array3.create int32 c_layout 2 3 4 in
+  for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do
+     a.{i,j,k} <- Int32.of_int((i lsl 4) + (j lsl 2) + k)
+  done done done;
+  let ok = ref true in
+  for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do
+     if Int32.to_int a.{i,j,k} <> (i lsl 4) + (j lsl 2) + k then ok := false
+  done done done;
+  test 1 true !ok;
+    
+  let b = Array3.create int64 fortran_layout 2 3 4 in
+  for i = 1 to 2 do for j = 1 to 3 do for k = 1 to 4 do
+     b.{i,j,k} <- Int64.of_int((i lsl 4) + (j lsl 2) + k)
+  done done done;
+  let ok = ref true in
+  for i = 1 to 2 do for j = 1 to 3 do for k = 1 to 4 do
+     if Int64.to_int b.{i,j,k} <> (i lsl 4) + (j lsl 2) + k then ok := false
+  done done done;
+  test 2 true !ok;
+
+  testing_function "dim";
+  let a = (make_array3 int c_layout 0 4 5 6 id) in
+  test 1 (Array3.dim1 a) 4;
+  test 2 (Array3.dim2 a) 5;
+  test 3 (Array3.dim3 a) 6;
+  let b =  (make_array3 int fortran_layout 1 4 5 6 id) in
+  test 4 (Array3.dim1 b) 4;
+  test 5 (Array3.dim2 b) 5;
+  test 6 (Array3.dim3 b) 6;
+
+  testing_function "slice1";
+  let a = make_array3 int c_layout 0 3 3 3 id in
+  test 1 (Array3.slice_left_1 a 0 0) (from_list int [0;1;2]);
+  test 2 (Array3.slice_left_1 a 0 1) (from_list int [10;11;12]);
+  test 3 (Array3.slice_left_1 a 0 2) (from_list int [20;21;22]);
+  test 4 (Array3.slice_left_1 a 1 1) (from_list int [110;111;112]);
+  test 5 (Array3.slice_left_1 a 2 1) (from_list int [210;211;212]);
+  let a = make_array3 int fortran_layout 1 3 3 3 id in
+  test 6 (Array3.slice_right_1 a 1 2) (from_list_fortran int [112;212;312]);
+  test 7 (Array3.slice_right_1 a 3 1) (from_list_fortran int [131;231;331]);
+
+(* Reshaping *)
+  print_newline();
+  testing_function "------ Reshaping --------";
+  testing_function "reshape_1";
+  let a = make_array2 int c_layout 0 3 4 id in
+  let b = make_array2 int fortran_layout 1 3 4 id in
+  let c = reshape_1 (genarray_of_array2 a) 12 in
+  test 1 c (from_list int [0;1;2;3;1000;1001;1002;1003;2000;2001;2002;2003]);
+  let d = reshape_1 (genarray_of_array2 b) 12 in
+  test 2 d (from_list_fortran int [1001;2001;3001;1002;2002;3002;1003;2003;3003;1004;2004;3004]);
+  testing_function "reshape_2";
+  let c = reshape_2 (genarray_of_array2 a) 4 3 in
+  test 1 (Array2.slice_left c 0) (from_list int [0;1;2]);
+  test 2 (Array2.slice_left c 1) (from_list int [3;1000;1001]);
+  test 3 (Array2.slice_left c 2) (from_list int [1002;1003;2000]);
+  test 4 (Array2.slice_left c 3) (from_list int [2001;2002;2003]);
+  let d = reshape_2 (genarray_of_array2 b) 4 3 in
+  test 5 (Array2.slice_right d 1) (from_list_fortran int [1001;2001;3001;1002]);
+  test 6 (Array2.slice_right d 2) (from_list_fortran int [2002;3002;1003;2003]);
+  test 7 (Array2.slice_right d 3) (from_list_fortran int [3003;1004;2004;3004]);
+
+(* I/O *)
+
+  print_newline();
+  testing_function "------ I/O --------";
+  testing_function "output_value/input_value";
+  let test_structured_io testno value =
+    let tmp = Filename.temp_file "bigarray" ".data" in
+    let oc = open_out_bin tmp in
+    output_value oc value;
+    close_out oc;
+    let ic = open_in_bin tmp in
+    let value' = input_value ic in
+    close_in ic;
+    Sys.remove tmp;
+    test testno value value' in
+  test_structured_io 1 (from_list int8_signed [1;2;3;-4;127;-128]);
+  test_structured_io 2 (from_list int16_signed [1;2;3;-4;127;-128]);
+  test_structured_io 3 (from_list int [1;2;3;-4;127;-128]);
+  test_structured_io 4
+    (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128]));
+  test_structured_io 5
+    (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128]));
+  test_structured_io 6
+    (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128]));
+  test_structured_io 7 (from_list float32 [0.0; 0.25; -4.0; 3.141592654]);
+  test_structured_io 8 (from_list float64 [0.0; 0.25; -4.0; 3.141592654]);
+  test_structured_io 9 (make_array2 int c_layout 0 100 100 id);
+  test_structured_io 10 (make_array2 float64 fortran_layout 1 200 200 float);
+  test_structured_io 11 (make_array3 int32 c_layout 0 20 30 40 Int32.of_int);
+  test_structured_io 12 (make_array3 float32 fortran_layout 1 10 50 100 float);
+  test_structured_io 13 (make_array2 complex32 c_layout 0 100 100 makecomplex);
+  test_structured_io 14 (make_array3 complex64 fortran_layout 1 10 20 30 makecomplex);
+
+  testing_function "map_file";
+  let mapped_file = Filename.temp_file "bigarray" ".data" in
+  begin
+    let fd =
+     Unix.openfile mapped_file
+                   [Unix.O_RDWR; Unix.O_TRUNC; Unix.O_CREAT] 0o666 in
+    let a = Array1.map_file fd float64 c_layout true 10000 in
+    Unix.close fd;
+    for i = 0 to 9999 do a.{i} <- float i done;
+    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+    let b = Array2.map_file fd float64 fortran_layout false 100 (-1) in
+    Unix.close fd;
+    let ok = ref true in
+    for i = 0 to 99 do
+      for j = 0 to 99 do
+        if b.{j+1,i+1} <> float (100 * i + j) then ok := false
+      done
+    done;
+    test 1 !ok true;
+    b.{50,50} <- (-1.0);
+    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+    let c = Array2.map_file fd float64 c_layout false (-1) 100 in
+    Unix.close fd;
+    let ok = ref true in
+    for i = 0 to 99 do
+      for j = 0 to 99 do
+        if c.{i,j} <> float (100 * i + j) then ok := false
+      done
+    done;
+    test 2 !ok true
+  end;
+  (* Force garbage collection of the mapped bigarrays above, otherwise
+     Win32 doesn't let us erase the file.  Notice the begin...end above
+     so that the VM doesn't keep stack references to the mapped bigarrays. *)
+  Gc.full_major();
+  Sys.remove mapped_file;
+
+  ()
+                  
+(********* End of test *********)
+
+let _ =
+  print_newline();
+  if !error_occurred then begin
+    prerr_endline "************* TEST FAILED ****************"; exit 2
+  end else
+    exit 0
diff --git a/test/Moretest/bigarrf.f b/test/Moretest/bigarrf.f
new file mode 100644
index 00000000..734863a0
--- /dev/null
+++ b/test/Moretest/bigarrf.f
@@ -0,0 +1,26 @@
+	subroutine filltab()
+
+	parameter (dimx = 8, dimy = 6)
+	real ftab(dimx, dimy)
+	common /ftab/ ftab
+	integer x, y
+
+	do 100 x = 1, dimx
+	   do 110 y = 1, dimy
+	      ftab(x, y) = x * 100 + y
+ 110	   continue
+ 100	continue
+	end
+
+	subroutine printtab(tab, dimx, dimy)
+
+	integer dimx, dimy
+	real tab(dimx, dimy)
+	integer x, y
+
+	do 200 x = 1, dimx
+	   print 300, x, (tab(x, y), y = 1, dimy)
+ 300	   format(/1X, I3, 2X, 10F6.1/)
+ 200	continue
+	end
+
diff --git a/test/Moretest/bigarrfml.ml b/test/Moretest/bigarrfml.ml
new file mode 100644
index 00000000..c9156228
--- /dev/null
+++ b/test/Moretest/bigarrfml.ml
@@ -0,0 +1,63 @@
+open Bigarray
+open Printf
+
+(* Test harness *)
+
+let error_occurred = ref false
+
+let function_tested = ref ""
+
+let testing_function s =
+    function_tested := s;
+    print_newline();
+    print_string s;
+    print_newline()
+
+let test test_number answer correct_answer =
+ flush stdout;
+ flush stderr;
+ if answer <> correct_answer then begin
+   eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number;
+   flush stderr;
+   error_occurred := true
+ end else begin
+   printf " %d..." test_number
+ end
+
+(* External C and Fortran functions *)
+
+external c_filltab : unit -> (float, float64_elt, c_layout) Array2.t = "c_filltab"
+external c_printtab : (float, float64_elt, c_layout) Array2.t -> unit = "c_printtab"
+external fortran_filltab : unit -> (float, float32_elt, fortran_layout) Array2.t = "fortran_filltab"
+external fortran_printtab : (float, float32_elt, fortran_layout) Array2.t -> unit = "fortran_printtab"
+
+let _ =
+
+  let make_array2 kind layout ind0 dim1 dim2 fromint =
+    let a = Array2.create kind layout dim1 dim2 in
+    for i = ind0 to dim1 - 1 + ind0 do
+      for j = ind0 to dim2 - 1 + ind0 do
+        a.{i,j} <- (fromint (i * 1000 + j))
+      done
+    done;
+    a in
+
+  print_newline();
+  testing_function "------ Foreign function interface --------";
+  testing_function "Passing an array to C";
+  c_printtab (make_array2 float64 c_layout 0 6 8 float);
+  testing_function "Accessing a C array";
+  let a = c_filltab () in
+  test 1 a.{0,0} 0.0;
+  test 2 a.{1,0} 100.0;
+  test 3 a.{0,1} 1.0;
+  test 4 a.{5,4} 504.0;
+  testing_function "Passing an array to Fortran";
+  fortran_printtab (make_array2 float32 fortran_layout 1 5 4 float);
+  testing_function "Accessing a Fortran array";
+  let a = fortran_filltab () in
+  test 1 a.{1,1} 101.0;
+  test 2 a.{2,1} 201.0;
+  test 3 a.{1,2} 102.0;
+  test 4 a.{5,4} 504.0;
+
diff --git a/test/Moretest/bigarrfstub.c b/test/Moretest/bigarrfstub.c
new file mode 100644
index 00000000..87bd67b7
--- /dev/null
+++ b/test/Moretest/bigarrfstub.c
@@ -0,0 +1,60 @@
+#include <stdio.h>
+#include <mlvalues.h>
+#include <bigarray.h>
+
+extern void filltab_(void);
+extern void printtab_(float * data, int * dimx, int * dimy);
+extern float ftab_[];
+
+#define DIMX 6
+#define DIMY 8
+
+double ctab[DIMX][DIMY];
+
+void filltab(void)
+{
+  int x, y;
+  for (x = 0; x < DIMX; x++)
+    for (y = 0; y < DIMY; y++)
+      ctab[x][y] = x * 100 + y;
+}
+
+void printtab(double tab[DIMX][DIMY])
+{
+  int x, y;
+  for (x = 0; x < DIMX; x++) {
+    printf("%3d", x);
+    for (y = 0; y < DIMY; y++)
+      printf("  %6.1f", tab[x][y]);
+    printf("\n");
+  }
+}
+
+value c_filltab(value unit)
+{
+  filltab();
+  return alloc_bigarray_dims(BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT,
+                             2, ctab, DIMX, DIMY);
+}
+
+value c_printtab(value ba)
+{
+  printtab(Data_bigarray_val(ba));
+  return Val_unit;
+}
+
+value fortran_filltab(value unit)
+{
+  filltab_();
+  return alloc_bigarray_dims(BIGARRAY_FLOAT32 | BIGARRAY_FORTRAN_LAYOUT,
+                             2, ftab_, 8, 6);
+}
+
+value fortran_printtab(value ba)
+{
+  int dimx = Bigarray_val(ba)->dim[0];
+  int dimy = Bigarray_val(ba)->dim[1];
+  printtab_(Data_bigarray_val(ba), &dimx, &dimy);
+  return Val_unit;
+}
+
diff --git a/test/Moretest/bigints.ml b/test/Moretest/bigints.ml
new file mode 100644
index 00000000..0b101ffa
--- /dev/null
+++ b/test/Moretest/bigints.ml
@@ -0,0 +1,12 @@
+let _ =
+  print_int 1000000000; print_newline();
+  print_int 10000000000; print_newline();
+  print_int 100000000000; print_newline();
+  print_int 1000000000000; print_newline();
+  print_int 10000000000000; print_newline();
+  print_int 100000000000000; print_newline();
+  print_int 1000000000000000; print_newline();
+  print_int 10000000000000000; print_newline();
+  print_int 100000000000000000; print_newline();
+  print_int 1000000000000000000; print_newline()
+
diff --git a/test/Moretest/bounds.ml b/test/Moretest/bounds.ml
new file mode 100644
index 00000000..a785c3c4
--- /dev/null
+++ b/test/Moretest/bounds.ml
@@ -0,0 +1,28 @@
+(* Test bound checks with ocamlopt *)
+
+let a = [| 0; 1; 2 |]
+
+let trail = ref []
+
+let test n =
+  let result =
+    try
+      trail := n :: !trail; a.(n); "doesn't fail"
+    with Invalid_argument s ->
+           (* Check well-formedness of s *)
+           if String.length s = 19
+           && s = "index out of bounds"
+           then "fails"
+           else "bad Invalid_argument"
+       | _ -> "bad exception"
+  in
+    print_int n; print_string ": "; print_string result; print_newline()
+
+let _ =
+  test 0; test 1; test 2; test 3; test 4; test (-1);
+  Gc.full_major();
+  print_string "Trail:";
+  List.iter (fun n -> print_string " "; print_int n) !trail;
+  print_newline()
+
+
diff --git a/test/Moretest/boxedints.ml b/test/Moretest/boxedints.ml
new file mode 100644
index 00000000..d5a1d5ba
--- /dev/null
+++ b/test/Moretest/boxedints.ml
@@ -0,0 +1,569 @@
+(* Test the types nativeint, int32, int64 *)
+
+open Printf
+
+let error_occurred = ref false
+
+let function_tested = ref ""
+
+let testing_function s =
+    function_tested := s;
+    print_newline();
+    print_string s;
+    print_newline()
+
+let test test_number answer correct_answer =
+ flush stdout;
+ flush stderr;
+ if answer <> correct_answer then begin
+   eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number;
+   flush stderr;
+   error_occurred := true
+ end else begin
+   printf " %d..." test_number
+ end
+
+(***** Tests on 32 bit arithmetic *****)
+
+module type TESTSIG = sig
+  type t
+  module Ops : sig
+    val neg: t -> t 
+    val add: t -> t -> t 
+    val sub: t -> t -> t 
+    val mul: t -> t -> t 
+    val div: t -> t -> t 
+    val rem: t -> t -> t 
+    val logand: t -> t -> t 
+    val logor: t -> t -> t 
+    val logxor: t -> t -> t 
+    val shift_left: t -> int -> t 
+    val shift_right: t -> int -> t 
+    val shift_right_logical: t -> int -> t 
+    val of_int: int -> t 
+    val to_int: t -> int 
+    val of_float: float -> t 
+    val to_float: t -> float
+    val zero: t
+    val one: t
+    val minus_one: t
+    val min_int: t
+    val max_int: t
+    val format : string -> t -> string 
+    val to_string: t -> string
+    val of_string: string -> t 
+  end
+  val testcomp: t -> t -> bool*bool*bool*bool*bool*bool*int
+end
+
+module Test32(M: TESTSIG) =
+struct
+  open M
+  open Ops
+
+  let _ =
+    testing_function "of_int, to_int";
+    test 1 (to_int (of_int 0)) 0;
+    test 2 (to_int (of_int 123)) 123;
+    test 3 (to_int (of_int (-456))) (-456);
+    test 4 (to_int (of_int 0x3FFFFFFF)) 0x3FFFFFFF;
+    test 5 (to_int (of_int (-0x40000000))) (-0x40000000);
+
+    testing_function "of_string";
+    test 1 (of_string "0") (of_int 0);
+    test 2 (of_string "123") (of_int 123);
+    test 3 (of_string "-456") (of_int (-456));
+    test 4 (of_string "123456789") (of_int 123456789);
+    test 5 (of_string "0xABCDEF") (of_int 0xABCDEF);
+    test 6 (of_string "-0o1234567012") (of_int (- 0o1234567012));
+    test 7 (of_string "0b01010111111000001100")
+           (of_int 0b01010111111000001100);
+    test 8 (of_string "0x7FFFFFFF") max_int;
+    test 9 (of_string "-0x80000000") min_int;
+    test 10 (of_string "0x80000000") min_int;
+    test 11 (of_string "0xFFFFFFFF") minus_one;
+
+    testing_function "to_string, format";
+    List.iter (fun (n, s) -> test n (to_string (of_string s)) s)
+      [1, "0"; 2, "123"; 3, "-456"; 4, "1234567890";
+       5, "2147483647"; 6, "-2147483648"];
+    List.iter (fun (n, s) -> test n (format "0x%X" (of_string s)) s)
+      [7, "0x0"; 8, "0x123"; 9, "0xABCDEF"; 10, "0x12345678";
+       11, "0x7FFFFFFF"; 12, "0x80000000"; 13, "0xFFFFFFFF"];
+    test 14 (to_string max_int) "2147483647";
+    test 15 (to_string min_int) "-2147483648";
+    test 16 (to_string zero) "0";
+    test 17 (to_string one) "1";
+    test 18 (to_string minus_one) "-1";
+
+    testing_function "neg";
+    test 1 (neg (of_int 0)) (of_int 0);
+    test 2 (neg (of_int 123)) (of_int (-123));
+    test 3 (neg (of_int (-456))) (of_int 456);
+    test 4 (neg (of_int 123456789)) (of_int (-123456789));
+    test 5 (neg max_int) (of_string "-0x7FFFFFFF");
+    test 6 (neg min_int) min_int;
+
+    testing_function "add";
+    test 1 (add (of_int 0) (of_int 0)) (of_int 0);
+    test 2 (add (of_int 123) (of_int 0)) (of_int 123);
+    test 3 (add (of_int 0) (of_int 456)) (of_int 456);
+    test 4 (add (of_int 123) (of_int 456)) (of_int 579);
+    test 5 (add (of_int (-123)) (of_int 456)) (of_int 333);
+    test 6 (add (of_int 123) (of_int (-456))) (of_int (-333));
+    test 7 (add (of_int (-123)) (of_int (-456))) (of_int (-579));
+    test 8 (add (of_string "0x12345678") (of_string "0x9ABCDEF"))
+           (of_string "0x1be02467");
+    test 9 (add max_int max_int) (of_int (-2));
+    test 10 (add min_int min_int) zero;
+    test 11 (add max_int one) min_int;
+    test 12 (add min_int minus_one) max_int;
+    test 13 (add max_int min_int) minus_one;
+
+    testing_function "sub";
+    test 1 (sub (of_int 0) (of_int 0)) (of_int 0);
+    test 2 (sub (of_int 123) (of_int 0)) (of_int 123);
+    test 3 (sub (of_int 0) (of_int 456)) (of_int (-456));
+    test 4 (sub (of_int 123) (of_int 456)) (of_int (-333));
+    test 5 (sub (of_int (-123)) (of_int 456)) (of_int (-579));
+    test 6 (sub (of_int 123) (of_int (-456))) (of_int 579);
+    test 7 (sub (of_int (-123)) (of_int (-456))) (of_int 333);
+    test 8 (sub (of_string "0x12345678") (of_string "0x9ABCDEF"))
+           (of_string "0x8888889");
+    test 9 (sub max_int min_int) minus_one;
+    test 10 (sub min_int max_int) one;
+    test 11 (sub min_int one) max_int;
+    test 12 (sub max_int minus_one) min_int;
+
+    testing_function "mul";
+    test 1 (mul (of_int 0) (of_int 0)) (of_int 0);
+    test 2 (mul (of_int 123) (of_int 0)) (of_int 0);
+    test 3 (mul (of_int 0) (of_int (-456))) (of_int 0);
+    test 4 (mul (of_int 123) (of_int 1)) (of_int 123);
+    test 5 (mul (of_int 1) (of_int (-456))) (of_int (-456));
+    test 6 (mul (of_int 123) (of_int (-1))) (of_int (-123));
+    test 7 (mul (of_int (-1)) (of_int (-456))) (of_int 456);
+    test 8 (mul (of_int 123) (of_int 456)) (of_int 56088);
+    test 9 (mul (of_int (-123)) (of_int 456)) (of_int (-56088));
+    test 10 (mul (of_int 123) (of_int (-456))) (of_int (-56088));
+    test 11 (mul (of_int (-123)) (of_int (-456))) (of_int 56088);
+    test 12 (mul (of_string "0x12345678") (of_string "0x9ABCDEF"))
+            (of_string "0xe242d208");
+    test 13 (mul max_int max_int) one;
+
+    testing_function "div";
+    List.iter
+      (fun (n, a, b) -> test n (div (of_int a) (of_int b)) (of_int (a / b)))
+      [1, 0, 2;
+       2, 123, 1;
+       3, -123, 1;
+       4, 123, -1;
+       5, -123, -1;
+       6, 1275312364, 365;
+       7, 16384, 256;
+       8, -1275312364, 365;
+       9, 1275312364, -365;
+       10, 1234567, 12345678;
+       11, 1234567, -12345678];
+
+    testing_function "mod";
+    List.iter
+      (fun (n, a, b) -> test n (rem (of_int a) (of_int b)) (of_int (a mod b)))
+      [1, 0, 2;
+       2, 123, 1;
+       3, -123, 1;
+       4, 123, -1;
+       5, -123, -1;
+       6, 1275312364, 365;
+       7, 16384, 256;
+       8, -1275312364, 365;
+       9, 1275312364, -365;
+       10, 1234567, 12345678;
+       11, 1234567, -12345678];
+
+    testing_function "and";
+    List.iter
+      (fun (n, a, b, c) -> test n (logand (of_string a) (of_string b))
+                                  (of_string c))
+      [1, "0x12345678", "0x9abcdef0", "0x12345670";
+       2, "0x12345678", "0x0fedcba9", "0x2244228";
+       3, "0xFFFFFFFF", "0x12345678", "0x12345678";
+       4, "0", "0x12345678", "0";
+       5, "0x55555555", "0xAAAAAAAA", "0"];
+
+    testing_function "or";
+    List.iter
+      (fun (n, a, b, c) -> test n (logor (of_string a) (of_string b))
+                                  (of_string c))
+      [1, "0x12345678", "0x9abcdef0", "0x9abcdef8";
+       2, "0x12345678", "0x0fedcba9", "0x1ffddff9";
+       3, "0xFFFFFFFF", "0x12345678", "0xFFFFFFFF";
+       4, "0", "0x12345678", "0x12345678";
+       5, "0x55555555", "0xAAAAAAAA", "0xFFFFFFFF"];
+
+    testing_function "xor";
+    List.iter
+      (fun (n, a, b, c) -> test n (logxor (of_string a) (of_string b))
+                                  (of_string c))
+      [1, "0x12345678", "0x9abcdef0", "0x88888888";
+       2, "0x12345678", "0x0fedcba9", "0x1dd99dd1";
+       3, "0xFFFFFFFF", "0x12345678", "0xedcba987";
+       4, "0", "0x12345678", "0x12345678";
+       5, "0x55555555", "0xAAAAAAAA", "0xFFFFFFFF"];
+
+    testing_function "shift_left";
+    List.iter
+      (fun (n, a, b, c) -> test n (shift_left (of_string a) b) (of_string c))
+      [1, "1", 1, "2";
+       2, "1", 2, "4";
+       3, "1", 4, "0x10";
+       4, "1", 30, "0x40000000";
+       5, "1", 31, "0x80000000";
+       6, "0x16236", 7, "0xb11b00";
+       7, "0x10", 27, "0x80000000";
+       8, "0x10", 28, "0"];
+
+    testing_function "shift_right";
+    List.iter
+      (fun (n, a, b, c) -> test n (shift_right (of_string a) b) (of_string c))
+      [1, "2", 1, "1";
+       2, "4", 2, "1";
+       3, "0x10", 4, "1";
+       4, "0x40000000", 10, "0x100000";
+       5, "0x80000000", 31, "-1";
+       6, "0xb11b00", 7, "0x16236";
+       7, "-0xb11b00", 7, "-90678"];
+
+    testing_function "shift_right_logical";
+    List.iter
+      (fun (n, a, b, c) -> test n (shift_right_logical (of_string a) b)
+                                  (of_string c))
+      [1, "2", 1, "1";
+       2, "4", 2, "1";
+       3, "0x10", 4, "1";
+       4, "0x40000000", 10, "0x100000";
+       5, "0x80000000", 31, "1";
+       6, "0xb11b00", 7, "0x16236";
+       7, "-0xb11b00", 7, "0x1fe9dca"];
+
+    testing_function "of_float";
+    test 1 (of_float 0.0) (of_int 0);
+    test 2 (of_float 123.0) (of_int 123);
+    test 3 (of_float 123.456) (of_int 123);
+    test 4 (of_float 123.999) (of_int 123);
+    test 5 (of_float (-456.0)) (of_int (-456));
+    test 6 (of_float (-456.123)) (of_int (-456));
+    test 7 (of_float (-456.789)) (of_int (-456));
+
+    testing_function "to_float";
+    test 1 (to_float (of_int 0)) 0.0;
+    test 2 (to_float (of_int 123)) 123.0;
+    test 3 (to_float (of_int (-456))) (-456.0);
+    test 4 (to_float (of_int 0x3FFFFFFF)) 1073741823.0;
+    test 5 (to_float (of_int (-0x40000000))) (-1073741824.0);
+
+    testing_function "Comparisons";
+    test 1 (testcomp (of_int 0) (of_int 0))
+           (true,false,false,false,true,true,0);
+    test 2 (testcomp (of_int 1234567) (of_int 1234567))
+           (true,false,false,false,true,true,0);
+    test 3 (testcomp (of_int 0) (of_int 1))
+           (false,true,true,false,true,false,-1);
+    test 4 (testcomp (of_int (-1)) (of_int 0))
+           (false,true,true,false,true,false,-1);
+    test 5 (testcomp (of_int 1) (of_int 0))
+           (false,true,false,true,false,true,1);
+    test 6 (testcomp (of_int 0) (of_int (-1)))
+           (false,true,false,true,false,true,1);
+    test 7 (testcomp max_int min_int)
+           (false,true,false,true,false,true,1);
+
+    ()
+end
+
+(********* Tests on 64-bit arithmetic ***********)
+
+module Test64(M: TESTSIG) =
+struct
+  open M
+  open Ops
+
+  let _ =
+    testing_function "of_int, to_int";
+    test 1 (to_int (of_int 0)) 0;
+    test 2 (to_int (of_int 123)) 123;
+    test 3 (to_int (of_int (-456))) (-456);
+    test 4 (to_int (of_int 0x3FFFFFFF)) 0x3FFFFFFF;
+    test 5 (to_int (of_int (-0x40000000))) (-0x40000000);
+
+    testing_function "of_string";
+    test 1 (of_string "0") (of_int 0);
+    test 2 (of_string "123") (of_int 123);
+    test 3 (of_string "-456") (of_int (-456));
+    test 4 (of_string "123456789") (of_int 123456789);
+    test 5 (of_string "0xABCDEF") (of_int 0xABCDEF);
+    test 6 (of_string "-0o1234567012") (of_int (- 0o1234567012));
+    test 7 (of_string "0b01010111111000001100")
+           (of_int 0b01010111111000001100);
+    test 8 (of_string "0x7FFFFFFFFFFFFFFF") max_int;
+    test 9 (of_string "-0x8000000000000000") min_int;
+    test 10 (of_string "0x8000000000000000") min_int;
+    test 11 (of_string "0xFFFFFFFFFFFFFFFF") minus_one;
+
+    testing_function "to_string, format";
+    List.iter (fun (n, s) -> test n (to_string (of_string s)) s)
+      [1, "0"; 2, "123"; 3, "-456"; 4, "1234567890";
+       5, "1234567890123456789";
+       6, "9223372036854775807";
+       7, "-9223372036854775808"];
+    List.iter (fun (n, s) -> test n ("0x" ^ format "%X" (of_string s)) s)
+      [7, "0x0"; 8, "0x123"; 9, "0xABCDEF"; 10, "0x1234567812345678";
+       11, "0x7FFFFFFFFFFFFFFF"; 12, "0x8000000000000000";
+       13, "0xFFFFFFFFFFFFFFFF"];
+    test 14 (to_string max_int) "9223372036854775807";
+    test 15 (to_string min_int) "-9223372036854775808";
+    test 16 (to_string zero) "0";
+    test 17 (to_string one) "1";
+    test 18 (to_string minus_one) "-1";
+
+    testing_function "neg";
+    test 1 (neg (of_int 0)) (of_int 0);
+    test 2 (neg (of_int 123)) (of_int (-123));
+    test 3 (neg (of_int (-456))) (of_int 456);
+    test 4 (neg (of_int 123456789)) (of_int (-123456789));
+    test 5 (neg max_int) (of_string "-0x7FFFFFFFFFFFFFFF");
+    test 6 (neg min_int) min_int;
+
+    testing_function "add";
+    test 1 (add (of_int 0) (of_int 0)) (of_int 0);
+    test 2 (add (of_int 123) (of_int 0)) (of_int 123);
+    test 3 (add (of_int 0) (of_int 456)) (of_int 456);
+    test 4 (add (of_int 123) (of_int 456)) (of_int 579);
+    test 5 (add (of_int (-123)) (of_int 456)) (of_int 333);
+    test 6 (add (of_int 123) (of_int (-456))) (of_int (-333));
+    test 7 (add (of_int (-123)) (of_int (-456))) (of_int (-579));
+    test 8 (add (of_string "0x1234567812345678") 
+                (of_string "0x9ABCDEF09ABCDEF"))
+           (of_string "0x1be024671be02467");
+    test 9 (add max_int max_int) (of_int (-2));
+    test 10 (add min_int min_int) zero;
+    test 11 (add max_int one) min_int;
+    test 12 (add min_int minus_one) max_int;
+    test 13 (add max_int min_int) minus_one;
+
+    testing_function "sub";
+    test 1 (sub (of_int 0) (of_int 0)) (of_int 0);
+    test 2 (sub (of_int 123) (of_int 0)) (of_int 123);
+    test 3 (sub (of_int 0) (of_int 456)) (of_int (-456));
+    test 4 (sub (of_int 123) (of_int 456)) (of_int (-333));
+    test 5 (sub (of_int (-123)) (of_int 456)) (of_int (-579));
+    test 6 (sub (of_int 123) (of_int (-456))) (of_int 579);
+    test 7 (sub (of_int (-123)) (of_int (-456))) (of_int 333);
+    test 8 (sub (of_string "0x1234567812345678") 
+                (of_string "0x9ABCDEF09ABCDEF"))
+           (of_string "0x888888908888889");
+    test 9 (sub max_int min_int) minus_one;
+    test 10 (sub min_int max_int) one;
+    test 11 (sub min_int one) max_int;
+    test 12 (sub max_int minus_one) min_int;
+
+    testing_function "mul";
+    test 1 (mul (of_int 0) (of_int 0)) (of_int 0);
+    test 2 (mul (of_int 123) (of_int 0)) (of_int 0);
+    test 3 (mul (of_int 0) (of_int (-456))) (of_int 0);
+    test 4 (mul (of_int 123) (of_int 1)) (of_int 123);
+    test 5 (mul (of_int 1) (of_int (-456))) (of_int (-456));
+    test 6 (mul (of_int 123) (of_int (-1))) (of_int (-123));
+    test 7 (mul (of_int (-1)) (of_int (-456))) (of_int 456);
+    test 8 (mul (of_int 123) (of_int 456)) (of_int 56088);
+    test 9 (mul (of_int (-123)) (of_int 456)) (of_int (-56088));
+    test 10 (mul (of_int 123) (of_int (-456))) (of_int (-56088));
+    test 11 (mul (of_int (-123)) (of_int (-456))) (of_int 56088);
+    test 12 (mul (of_string "0x12345678") (of_string "0x9ABCDEF"))
+           (of_string "0xb00ea4e242d208");
+    test 13 (mul max_int max_int) one;
+
+    testing_function "div";
+    List.iter
+      (fun (n, a, b) -> test n (div (of_int a) (of_int b)) (of_int (a / b)))
+      [1, 0, 2;
+       2, 123, 1;
+       3, -123, 1;
+       4, 123, -1;
+       5, -123, -1;
+       6, 1275312364, 365;
+       7, 16384, 256;
+       8, -1275312364, 365;
+       9, 1275312364, -365;
+       10, 1234567, 12345678;
+       11, 1234567, -12345678];
+
+    testing_function "mod";
+    List.iter
+      (fun (n, a, b) -> test n (rem (of_int a) (of_int b)) (of_int (a mod b)))
+      [1, 0, 2;
+       2, 123, 1;
+       3, -123, 1;
+       4, 123, -1;
+       5, -123, -1;
+       6, 1275312364, 365;
+       7, 16384, 256;
+       8, -1275312364, 365;
+       9, 1275312364, -365;
+       10, 1234567, 12345678;
+       11, 1234567, -12345678];
+
+    testing_function "and";
+    List.iter
+      (fun (n, a, b, c) -> test n (logand (of_string a) (of_string b))
+                                  (of_string c))
+      [1, "0x1234567812345678", "0x9abcdef09abcdef0", "0x1234567012345670";
+       2, "0x1234567812345678", "0x0fedcba90fedcba9", "0x224422802244228";
+       3, "0xFFFFFFFFFFFFFFFF", "0x1234000012345678", "0x1234000012345678";
+       4, "0", "0x1234567812345678", "0";
+       5, "0x5555555555555555", "0xAAAAAAAAAAAAAAAA", "0"];
+
+    testing_function "or";
+    List.iter
+      (fun (n, a, b, c) -> test n (logor (of_string a) (of_string b))
+                                  (of_string c))
+      [1, "0x1234567812345678", "0x9abcdef09abcdef0", "0x9abcdef89abcdef8";
+       2, "0x1234567812345678", "0x0fedcba90fedcba9", "0x1ffddff91ffddff9";
+       3, "0xFFFFFFFFFFFFFFFF", "0x12345678", "0xFFFFFFFFFFFFFFFF";
+       4, "0", "0x1234567812340000", "0x1234567812340000";
+       5, "0x5555555555555555", "0xAAAAAAAAAAAAAAAA", "0xFFFFFFFFFFFFFFFF"];
+
+    testing_function "xor";
+    List.iter
+      (fun (n, a, b, c) -> test n (logxor (of_string a) (of_string b))
+                                  (of_string c))
+      [1, "0x1234567812345678", "0x9abcdef09abcdef0", "0x8888888888888888";
+       2, "0x1234567812345678", "0x0fedcba90fedcba9", "0x1dd99dd11dd99dd1";
+       3, "0xFFFFFFFFFFFFFFFF", "0x123456789ABCDEF", "0xfedcba9876543210";
+       4, "0", "0x1234567812340000", "0x1234567812340000";
+       5, "0x5555555555555555", "0xAAAAAAAAAAAAAAAA", "0xFFFFFFFFFFFFFFFF"];
+
+    testing_function "shift_left";
+    List.iter
+      (fun (n, a, b, c) -> test n (shift_left (of_string a) b) (of_string c))
+      [1, "1", 1, "2";
+       2, "1", 2, "4";
+       3, "1", 4, "0x10";
+       4, "1", 62, "0x4000000000000000";
+       5, "1", 63, "0x8000000000000000";
+       6, "0x16236ABD45673", 7, "0xb11b55ea2b3980";
+       7, "0x10", 59, "0x8000000000000000";
+       8, "0x10", 60, "0"];
+
+    testing_function "shift_right";
+    List.iter
+      (fun (n, a, b, c) -> test n (shift_right (of_string a) b) (of_string c))
+      [1, "2", 1, "1";
+       2, "4", 2, "1";
+       3, "0x10", 4, "1";
+       4, "0x40000000", 10, "0x100000";
+       5, "0x8000000000000000", 63, "-1";
+       6, "0xb11b55ea2b3980", 7, "0x16236ABD45673";
+       7, "-0xb11b55ea2b3980", 7, "-389461927286387"];
+
+    testing_function "shift_right_logical";
+    List.iter
+      (fun (n, a, b, c) -> test n (shift_right_logical (of_string a) b)
+                                  (of_string c))
+      [1, "2", 1, "1";
+       2, "4", 2, "1";
+       3, "0x10", 4, "1";
+       4, "0x40000000", 10, "0x100000";
+       5, "0x8000000000000000", 63, "1";
+       6, "0xb11b55ea2b3980", 7, "0x16236ABD45673";
+       7, "-0xb11b55ea2b3980", 7, "0x1fe9dc9542ba98d"];
+
+    testing_function "Comparisons";
+    test 1 (testcomp (of_int 0) (of_int 0))
+           (true,false,false,false,true,true,0);
+    test 2 (testcomp (of_int 1234567) (of_int 1234567))
+           (true,false,false,false,true,true,0);
+    test 3 (testcomp (of_int 0) (of_int 1))
+           (false,true,true,false,true,false,-1);
+    test 4 (testcomp (of_int (-1)) (of_int 0))
+           (false,true,true,false,true,false,-1);
+    test 5 (testcomp (of_int 1) (of_int 0))
+           (false,true,false,true,false,true,1);
+    test 6 (testcomp (of_int 0) (of_int (-1)))
+           (false,true,false,true,false,true,1);
+    test 7 (testcomp max_int min_int)
+           (false,true,false,true,false,true,1);
+
+    ()
+end
+
+(******** The test proper **********)
+
+let testcomp_int32 (a : int32) (b : int32) =
+  (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b)
+let testcomp_int64 (a : int64) (b : int64) =
+  (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b)
+let testcomp_nativeint (a : nativeint) (b : nativeint) =
+  (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b)
+
+let _ =
+  testing_function "-------- Int32 --------";
+  let module A = Test32(struct type t = int32
+                               module Ops = Int32
+                               let testcomp = testcomp_int32 end) in
+  print_newline(); testing_function "-------- Int64 --------";
+  let module B = Test64(struct type t = int64
+                               module Ops = Int64
+                               let testcomp = testcomp_int64 end) in
+  print_newline(); testing_function "-------- Nativeint --------";
+  begin match Sys.word_size with
+    32 ->
+      let module C =
+        Test32(struct type t = nativeint 
+                      module Ops = Nativeint
+                      let testcomp = testcomp_nativeint end)
+      in ()
+  | 64 ->
+      let module C =
+        Test64(struct type t = nativeint
+                      module Ops = Nativeint
+                      let testcomp = testcomp_nativeint end)
+      in ()
+  | _ ->
+      assert false
+  end;
+  print_newline(); testing_function "--------- Conversions -----------";
+  testing_function "nativeint of/to int32";
+  test 1 (Nativeint.of_int32 (Int32.of_string "0x12345678"))
+         (Nativeint.of_string "0x12345678");
+  test 2 (Nativeint.to_int32 (Nativeint.of_string "0x12345678"))
+         (Int32.of_string "0x12345678");
+  test 3 (Nativeint.to_int32 (Nativeint.of_string "0x123456789ABCDEF0"))
+         (Int32.of_string "0x9ABCDEF0");
+  testing_function "int64 of/to int32";
+  test 1 (Int64.of_int32 (Int32.of_string "-0x12345678"))
+         (Int64.of_string "-0x12345678");
+  test 2 (Int64.to_int32 (Int64.of_string "-0x12345678"))
+         (Int32.of_string "-0x12345678");
+  test 3 (Int64.to_int32 (Int64.of_string "0x123456789ABCDEF0"))
+         (Int32.of_string "0x9ABCDEF0");
+  testing_function "int64 of/to nativeint";
+  test 1 (Int64.of_nativeint (Nativeint.of_string "0x12345678"))
+         (Int64.of_string "0x12345678");
+  test 2 (Int64.to_nativeint (Int64.of_string "-0x12345678"))
+         (Nativeint.of_string "-0x12345678");
+  test 3 (Int64.to_nativeint (Int64.of_string "0x123456789ABCDEF0"))
+         (Nativeint.of_string "0x123456789ABCDEF0");
+  test 4 (Int64.of_nativeint (Nativeint.of_string "0x9ABCDEF012345678"))
+         (if Sys.word_size = 64
+          then Int64.of_string "0x9ABCDEF012345678"
+          else Int64.of_string "0x12345678")
+
+(********* End of test *********)
+
+let _ =
+  print_newline();
+  if !error_occurred then begin
+    prerr_endline "************* TEST FAILED ****************"; exit 2
+  end else
+    exit 0
diff --git a/test/Moretest/callback.ml b/test/Moretest/callback.ml
new file mode 100644
index 00000000..025c7a46
--- /dev/null
+++ b/test/Moretest/callback.ml
@@ -0,0 +1,69 @@
+external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1"
+external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2"
+external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd = "mycallback3"
+external mycallback4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4"
+
+let rec tak (x, y, z as tuple) =
+  if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
+           else z
+
+let tak2 x (y, z) = tak (x, y, z)
+
+let tak3 x y z = tak (x, y, z)
+
+let tak4 x y z u = tak (x, y, z + u)
+
+let raise_exit () = (raise Exit : unit)
+
+let trapexit () =
+  begin try
+    mycallback1 raise_exit ()
+  with Exit ->
+    ()
+  end;
+  tak (18, 12, 6)
+
+external mypushroot : 'a -> ('b -> 'c) -> 'b -> 'a = "mypushroot"
+external mycamlparam : 'a -> ('b -> 'c) -> 'b -> 'a = "mycamlparam"
+
+let tripwire f =
+  let s = String.make 5 'a' in
+  f s trapexit ()
+
+(* Test callbacks performed to handle signals *)
+
+let sighandler signo =
+(*
+  print_string "Got signal, triggering garbage collection...";
+  print_newline();
+*)
+  (* Thoroughly wipe the minor heap *)
+  tak (18, 12, 6);
+  ()
+
+external unix_getpid : unit -> int = "unix_getpid" "noalloc"
+external unix_kill : int -> int -> unit = "unix_kill" "noalloc"
+
+let callbacksig () =
+  let pid = unix_getpid() in
+  (* Allocate a block in the minor heap *)
+  let s = String.make 5 'b' in
+  (* Send a signal to self.  We want s to remain in a register and
+     not be spilled on the stack, hence we declare unix_kill
+     "noalloc". *)
+  unix_kill pid Sys.sigusr1;
+  (* Allocate some more so that the signal will be tested *)
+  let u = (s, s) in
+  fst u
+
+let _ =
+  print_int(mycallback1 tak (18, 12, 6)); print_newline();
+  print_int(mycallback2 tak2 18 (12, 6)); print_newline();
+  print_int(mycallback3 tak3 18 12 6); print_newline();
+  print_int(mycallback4 tak4 18 12 3 3); print_newline();
+  print_int(trapexit ()); print_newline();
+  print_string(tripwire mypushroot); print_newline();
+  print_string(tripwire mycamlparam); print_newline();
+  Sys.signal Sys.sigusr1 (Sys.Signal_handle sighandler);
+  print_string(callbacksig ()); print_newline()
+
diff --git a/test/Moretest/callbackprim.c b/test/Moretest/callbackprim.c
new file mode 100644
index 00000000..f1a4ccfa
--- /dev/null
+++ b/test/Moretest/callbackprim.c
@@ -0,0 +1,54 @@
+#include "mlvalues.h"
+#include "memory.h"
+#include "callback.h"
+
+value mycallback1(value fun, value arg)
+{
+  value res;
+  res = callback(fun, arg);
+  return res;
+}
+
+value mycallback2(value fun, value arg1, value arg2)
+{
+  value res;
+  res = callback2(fun, arg1, arg2);
+  return res;
+}
+
+value mycallback3(value fun, value arg1, value arg2, value arg3)
+{
+  value res;
+  res = callback3(fun, arg1, arg2, arg3);
+  return res;
+}
+
+value mycallback4(value fun, value arg1, value arg2, value arg3, value arg4)
+{
+  value args[4];
+  value res;
+  args[0] = arg1;
+  args[1] = arg2;
+  args[2] = arg3;
+  args[3] = arg4;
+  res = callbackN(fun, 4, args);
+  return res;
+}
+
+value mypushroot(value v, value fun, value arg)
+{
+  Begin_root(v)
+    callback(fun, arg);
+  End_roots();
+  return v;
+}
+
+value mycamlparam (value v, value fun, value arg)
+{
+  CAMLparam3 (v, fun, arg);
+  CAMLlocal2 (x, y);
+  x = v;
+  y = callback (fun, arg);
+  v = x;
+  CAMLreturn (v);
+}
diff --git a/test/Moretest/cmcaml.ml b/test/Moretest/cmcaml.ml
new file mode 100644
index 00000000..a7e1cf55
--- /dev/null
+++ b/test/Moretest/cmcaml.ml
@@ -0,0 +1,17 @@
+(* Caml part of the code *)
+
+let rec fib n =
+  if n < 2 then 1 else fib(n-1) + fib(n-2)
+
+let format_result n =
+  let r = "Result = " ^ string_of_int n in
+  (* Allocate gratuitously to test GC *)
+  for i = 1 to 1500 do String.create 256 done;
+  r
+
+(* Registration *)
+
+let _ =
+  Callback.register "fib" fib;
+  Callback.register "format_result" format_result
+
diff --git a/test/Moretest/cmmain.c b/test/Moretest/cmmain.c
new file mode 100644
index 00000000..4894361b
--- /dev/null
+++ b/test/Moretest/cmmain.c
@@ -0,0 +1,21 @@
+/* Main program -- in C */
+
+#include <stdlib.h>
+#include <caml/callback.h>
+
+extern int fib(int n);
+extern char * format_result(int n);
+
+int main(int argc, char ** argv)
+{
+  printf("Initializing Caml code...\n");
+#ifdef NO_BYTECODE_FILE
+  caml_startup(argv);
+#else
+  caml_main(argv);
+#endif
+  printf("Back in C code...\n");
+  printf("Computing fib(20)...\n");
+  printf("%s\n", format_result(fib(20)));
+  return 0;
+}
diff --git a/test/Moretest/cmstub.c b/test/Moretest/cmstub.c
new file mode 100644
index 00000000..56cd6944
--- /dev/null
+++ b/test/Moretest/cmstub.c
@@ -0,0 +1,17 @@
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/callback.h>
+
+/* Functions callable directly from C */
+
+int fib(int n)
+{
+  value * fib_closure = caml_named_value("fib");
+  return Int_val(callback(*fib_closure, Val_int(n)));
+}
+
+char * format_result(int n)
+{
+  value * format_result_closure = caml_named_value("format_result");
+  return strdup(String_val(callback(*format_result_closure, Val_int(n))));
+}
diff --git a/test/Moretest/equality.ml b/test/Moretest/equality.ml
new file mode 100644
index 00000000..05e65123
--- /dev/null
+++ b/test/Moretest/equality.ml
@@ -0,0 +1,71 @@
+let test n exp res =
+  prerr_string "Test "; prerr_int n;
+  if exp = res then prerr_string " passed.\n" else prerr_string " FAILED.\n";
+  flush stderr
+
+let x = [1;2;3]
+
+let f x = 1 :: 2 :: 3 :: x
+
+let mklist len =
+  let l = ref [] in
+  for i = 1 to len do l := i :: !l done;
+  !l
+
+type tree = Dummy | Leaf | Node of tree * tree
+
+let rec mktree depth =
+  if depth <= 0 then Leaf else Node(mktree(depth - 1), mktree(depth - 1))
+
+type 'a leftlist = Nil | Cons of 'a leftlist * 'a
+
+let mkleftlist len =
+  let l = ref Nil in
+  for i = 1 to len do l := Cons(!l, i) done;
+  !l
+
+let _ =
+  test 1 0 (compare 0 0);
+  test 2 (-1) (compare 0 1);
+  test 3 1 (compare 1 0);
+  test 4 0 (compare max_int max_int);
+  test 5 (-1) (compare min_int max_int);
+  test 6 1 (compare max_int min_int);
+  test 7 0 (compare "foo" "foo");
+  test 8 (-1) (compare "foo" "zorglub");
+  test 9 (-1) (compare "abcdef" "foo");
+  test 10 (-1) (compare "abcdefghij" "abcdefghijkl");
+  test 11 1 (compare "abcdefghij" "abcdefghi");
+  test 12 0 (compare (0,1) (0,1));
+  test 13 (-1) (compare (0,1) (0,2));
+  test 14 (-1) (compare (0,1) (1,0));
+  test 15 1 (compare (0,1) (0,0));
+  test 16 1 (compare (1,0) (0,1));
+  test 17 0 (compare 0.0 0.0);
+  test 18 (-1) (compare 0.0 1.0);
+  test 19 (-1) (compare (-1.0) 0.0);
+  test 20 0 (compare [| 0.0; 1.0; 2.0 |] [| 0.0; 1.0; 2.0 |]);
+  test 21 (-1) (compare [| 0.0; 1.0; 2.0 |] [| 0.0; 1.0; 3.0 |]);
+  test 22 1 (compare [| 0.0; 5.0; 2.0 |] [| 0.0; 1.0; 2.0 |]);
+  test 23 0 (compare [1;2;3;4] [1;2;3;4]);
+  test 24 (-1) (compare [1;2;3;4] [1;2;5;6]);
+  test 25 (-1) (compare [1;2;3;4] [1;2;3;4;5]);
+  test 26 1 (compare [1;2;3;4] [1;2;3]);
+  test 27 1 (compare [1;2;3;4] [1;2;0;4]);
+  test 28 0 (compare (mklist 1000) (mklist 1000));
+  test 29 0 (compare (mkleftlist 1000) (mkleftlist 1000));
+  test 30 0 (compare (mktree 12) (mktree 12));
+  test 31 true (x = f []);
+  test 32 true (stdout <> stderr);
+  test 33 (-1) (compare nan 0.0);
+  test 34 (-1) (compare nan neg_infinity);
+  test 35 0 (compare nan nan);
+  test 36 (-1) (compare (0.0, nan) (0.0, 0.0));
+  test 37 (-1) (compare (0.0, nan) (0.0, neg_infinity));
+  test 38 0 (compare (nan, 0.0) (nan, 0.0));
+  let cmpgen x y = (x=y, x<>y, x<y, x<=y, x>y, x>=y) in
+  let cmpfloat (x:float) (y:float) = (x=y, x<>y, x<y, x<=y, x>y, x>=y) in
+  test 39 (false,true,false,false,false,false) (cmpgen nan nan);
+  test 40 (false,true,false,false,false,false) (cmpgen nan 0.0);
+  test 41 (false,true,false,false,false,false) (cmpfloat nan nan);
+  test 42 (false,true,false,false,false,false) (cmpfloat nan 0.0)
diff --git a/test/Moretest/fftba.ml b/test/Moretest/fftba.ml
new file mode 100644
index 00000000..799380cd
--- /dev/null
+++ b/test/Moretest/fftba.ml
@@ -0,0 +1,191 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: fftba.ml,v 1.1 2000/03/10 14:54:41 xleroy Exp $ *)
+
+open Bigarray
+
+let pi = 3.14159265358979323846
+
+let tpi = 2.0 *. pi
+
+let fft (px : (float, float64_elt, c_layout) Array1.t)
+        (py : (float, float64_elt, c_layout) Array1.t) np =
+  let i = ref 2 in
+  let m = ref 1 in
+  
+  while (!i < np) do
+    i := !i + !i; 
+    m := !m + 1
+  done;
+
+  let n = !i in  
+  
+  if n <> np then begin
+    for i = np+1 to n do
+      px.{i} <- 0.0; 
+      py.{i} <- 0.0
+    done;
+    print_string "Use "; print_int n;
+    print_string " point fft"; print_newline()
+  end;
+
+  let n2 = ref(n+n) in
+  for k = 1 to !m-1 do
+    n2 := !n2 / 2; 
+    let n4 = !n2 / 4 in
+    let e  = tpi /. float !n2 in
+
+    for j = 1 to n4 do
+      let a = e *. float(j - 1) in
+      let a3 = 3.0 *. a in
+      let cc1 = cos(a) in
+      let ss1 = sin(a) in
+      let cc3 = cos(a3) in
+      let ss3 = sin(a3) in
+      let is = ref j in
+      let id = ref(2 * !n2) in
+  
+        while !is < n do
+          let i0r = ref !is in
+          while !i0r < n do
+             let i0 = !i0r in
+             let i1 = i0 + n4 in
+             let i2 = i1 + n4 in
+             let i3 = i2 + n4 in
+             let r1 = px.{i0} -. px.{i2} in
+             px.{i0} <- px.{i0} +. px.{i2};
+             let r2 = px.{i1} -. px.{i3} in
+             px.{i1} <- px.{i1} +. px.{i3};
+             let s1 = py.{i0} -. py.{i2} in
+             py.{i0} <- py.{i0} +. py.{i2};
+             let s2 = py.{i1} -. py.{i3} in
+             py.{i1} <- py.{i1} +. py.{i3};
+             let s3 = r1 -. s2 in
+             let r1 = r1 +. s2 in
+             let s2 = r2 -. s1 in
+             let r2 = r2 +. s1 in
+             px.{i2} <- r1*.cc1 -. s2*.ss1; 
+             py.{i2} <- -.s2*.cc1 -. r1*.ss1;
+             px.{i3} <- s3*.cc3 +. r2*.ss3;
+             py.{i3} <- r2*.cc3 -. s3*.ss3;
+             i0r := i0 + !id
+          done;
+          is := 2 * !id - !n2 + j; 
+          id := 4 * !id
+        done
+    done
+  done;
+
+(************************************)
+(*  Last stage, length=2 butterfly  *)
+(************************************)
+
+  let is = ref 1 in
+  let id = ref 4 in
+  
+  while !is < n do
+    let i0r = ref !is in
+    while !i0r <= n do
+      let i0 = !i0r in
+      let i1 = i0 + 1 in
+      let r1 = px.{i0} in
+      px.{i0} <- r1 +. px.{i1};
+      px.{i1} <- r1 -. px.{i1};
+      let r1 = py.{i0} in
+      py.{i0} <- r1 +. py.{i1};
+      py.{i1} <- r1 -. py.{i1};
+      i0r := i0 + !id
+    done;
+    is := 2 * !id - 1; 
+    id := 4 * !id
+  done;
+
+(*************************)
+(*  Bit reverse counter  *)
+(*************************)
+
+  let j = ref 1 in
+  
+  for i = 1 to n - 1 do
+    if i < !j then begin
+      let xt = px.{!j} in
+      px.{!j} <- px.{i}; 
+      px.{i} <- xt;
+      let xt = py.{!j} in
+      py.{!j} <- py.{i};
+      py.{i} <- xt
+    end;
+    let k = ref(n / 2) in
+    while !k < !j do
+      j := !j - !k; 
+      k := !k / 2
+    done;
+    j := !j + !k
+  done;
+
+  n
+
+
+let test np =
+  print_int np; print_string "... "; flush stdout;
+  let enp = float np in
+  let npm = np / 2 - 1 in
+  let pxr = Array1.create float64 c_layout (np+2)
+  and pxi = Array1.create float64 c_layout (np+2) in
+  let t = pi /. enp in
+  pxr.{1} <- (enp -. 1.0) *. 0.5;
+  pxi.{1} <- 0.0;
+  let n2 = np / 2 in
+  pxr.{n2+1} <- -0.5;
+  pxi.{n2+1} <-  0.0;
+
+  for i = 1 to npm do
+      let j = np - i in
+      pxr.{i+1} <- -0.5;
+      pxr.{j+1} <- -0.5;
+      let z = t *. float i in
+      let y = -0.5 *. (cos(z)/.sin(z)) in
+      pxi.{i+1} <- y;
+      pxi.{j+1} <- -.y
+  done;
+(**
+  print_newline();
+  for i=0 to 15 do Printf.printf "%d  %f  %f\n" i pxr.{i+1} pxi.{i+1} done;
+**)
+  let _ = fft pxr pxi np in
+(**
+  for i=0 to 15 do Printf.printf "%d  %f  %f\n" i pxr.{i+1} pxi.{i+1} done;
+**)
+  let zr = ref 0.0 in
+  let zi = ref 0.0 in
+  let kr = ref 0 in
+  let ki = ref 0 in
+  for i = 0 to np-1 do
+      let a = abs_float(pxr.{i+1} -. float i) in
+      if !zr < a then begin
+         zr := a; 
+         kr := i
+      end;
+      let a = abs_float(pxi.{i+1}) in
+      if !zi < a then begin
+         zi := a; 
+         ki := i
+      end
+  done;
+  let zm = if abs_float !zr < abs_float !zi then !zi else !zr in
+  print_float zm; print_newline()
+
+
+let _ =
+  let np = ref 16 in for i = 1 to 13 do test !np; np := !np*2 done
+
diff --git a/test/Moretest/float.ml b/test/Moretest/float.ml
new file mode 100644
index 00000000..9ebabbc4
--- /dev/null
+++ b/test/Moretest/float.ml
@@ -0,0 +1 @@
+Printf.printf "1./.0. = %f\n" (1.0 /. 0.0);;
diff --git a/test/Moretest/globroots.ml b/test/Moretest/globroots.ml
new file mode 100644
index 00000000..4d1ba4d4
--- /dev/null
+++ b/test/Moretest/globroots.ml
@@ -0,0 +1,25 @@
+type t
+
+external register: string -> t = "gb_register"
+external get: t -> string = "gb_get"
+external remove: t -> unit = "gb_remove"
+
+let size = 1024
+
+let _ =
+  let a = Array.init size (fun i -> register (string_of_int i)) in
+  while true do
+    (* Check data *)
+    for i = 0 to size - 1 do
+      if get a.(i) <> string_of_int i then begin
+        print_string "Error on "; print_int i; print_string ": ";
+        print_string (String.escaped (get a.(i))); print_newline()
+      end
+    done;
+    (* Change it randomly *)
+    let i = Random.int size in
+    remove a.(i);
+    a.(i) <- register (string_of_int i);
+    Gc.full_major();
+    print_string "."; flush stdout
+  done
diff --git a/test/Moretest/globrootsprim.c b/test/Moretest/globrootsprim.c
new file mode 100644
index 00000000..711f47a4
--- /dev/null
+++ b/test/Moretest/globrootsprim.c
@@ -0,0 +1,29 @@
+/* For testing global root registration */
+
+#include "mlvalues.h"
+#include "memory.h"
+#include "alloc.h"
+
+struct block { value v; };
+
+#define Block_val(v) ((struct block *) (v))
+
+value gb_register(value v)
+{
+  struct block * b = stat_alloc(sizeof(struct block));
+  b->v = v;
+  register_global_root(&(b->v));
+  return (value) b;
+}
+
+value gb_get(value vblock)
+{
+  return Block_val(vblock)->v;
+}
+
+value gb_remove(value vblock)
+{
+  remove_global_root(&(Block_val(vblock)->v));
+  return Val_unit;
+}
+
diff --git a/test/Moretest/graph_example.ml b/test/Moretest/graph_example.ml
new file mode 100644
index 00000000..6fbe988c
--- /dev/null
+++ b/test/Moretest/graph_example.ml
@@ -0,0 +1,131 @@
+(* To run this example:
+   ********************
+   1. Select all the text in this window.
+   2. Drag it to the toplevel window.
+   3. Watch the colors.
+   4. Drag the mouse over the graphics window and click here and there.
+   5. Type any key to the graphics window to stop the program.
+*)
+
+open Graphics;;
+open_graph " 480x270";;
+
+let xr = size_x () / 2 - 30
+and yr = size_y () / 2 - 26
+and xg = size_x () / 2 + 30
+and yg = size_y () / 2 - 26
+and xb = size_x () / 2
+and yb = size_y () / 2 + 26
+;;
+
+let point x y =
+  let dr = (x-xr)*(x-xr) + (y-yr)*(y-yr)
+  and dg = (x-xg)*(x-xg) + (y-yg)*(y-yg)
+  and db = (x-xb)*(x-xb) + (y-yb)*(y-yb)
+  in
+  if dr > dg && dr > db then set_color (rgb 255 (255*dg/dr) (255*db/dr))
+  else if dg > db then set_color (rgb (255*dr/dg) 255 (255*db/dg))
+  else set_color (rgb (255*dr/db) (255*dg/db) 255);
+  fill_rect x y 2 2;
+;;
+
+for y = (size_y () - 1) / 2 downto 0 do
+  for x = 0 to (size_x () - 1) / 2 do
+    point (2*x) (2*y);
+  done
+done
+;;
+
+let n = 0x000000
+and w = 0xFFFFFF
+and b = 0xFFCC99
+and y = 0xFFFF00
+and o = 0xCC9966
+and v = 0x00BB00
+and g = 0x888888
+and c = 0xDDDDDD
+and t = transp
+;;
+
+let caml = make_image [|
+  [|t;t;t;t;t;t;t;t;t;t;t;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;t;t;t;|];
+  [|t;t;t;t;t;t;t;t;t;t;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;t;|];
+  [|t;t;t;t;t;t;t;t;n;n;n;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;|];
+  [|n;n;n;n;n;n;t;n;n;n;n;n;b;b;b;b;b;b;b;n;n;t;t;t;t;t;n;n;n;n;n;t;|];
+  [|n;o;o;o;o;o;n;n;n;n;b;b;b;b;b;b;b;b;b;b;b;n;n;n;n;n;n;n;n;n;n;t;|];
+  [|n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;|];
+  [|n;o;o;o;o;o;o;o;n;n;n;g;g;g;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;|];
+  [|n;n;o;o;o;o;o;o;o;n;n;n;c;c;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;|];
+  [|t;n;n;o;o;o;o;o;o;o;n;n;n;c;n;n;n;n;n;n;n;b;b;n;n;n;n;n;n;t;t;t;|];
+  [|t;t;n;n;n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;n;b;b;b;b;n;n;n;n;t;t;t;t;|];
+  [|t;t;t;t;n;n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;b;b;b;b;b;b;n;n;t;t;t;t;|];
+  [|t;t;t;t;t;n;n;o;o;o;o;o;o;n;n;n;n;n;n;o;o;b;b;b;b;b;b;n;n;t;t;t;|];
+  [|t;t;t;t;t;n;n;o;o;o;o;o;o;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;t;t;|];
+  [|t;t;t;t;n;n;n;o;o;o;o;o;b;b;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;t;|];
+  [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;|];
+  [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;n;n;o;o;b;b;b;b;b;n;n;|];
+  [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;n;n;o;o;b;o;b;b;n;n;|];
+  [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;b;n;n;o;o;o;o;o;n;n;|];
+  [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;b;b;n;n;o;o;o;o;n;n;|];
+  [|t;t;t;t;n;n;n;o;o;o;o;o;b;b;b;b;n;n;b;b;b;b;b;b;b;n;n;o;o;n;n;n;|];
+  [|t;t;t;t;n;n;n;n;o;o;o;o;o;b;b;b;n;n;n;b;b;b;b;b;b;b;n;n;o;n;b;n;|];
+  [|t;t;t;t;t;n;n;n;o;o;o;o;o;o;b;b;n;n;n;b;b;b;b;b;b;b;b;n;n;n;b;n;|];
+  [|t;t;t;t;t;t;n;n;o;o;o;o;o;o;o;y;v;y;n;b;b;b;b;b;b;b;b;n;n;b;b;n;|];
+  [|t;t;t;t;t;t;t;n;o;o;o;o;o;v;y;o;o;n;n;n;b;b;b;b;b;b;b;n;n;b;b;n;|];
+  [|t;t;t;t;t;t;t;n;o;o;o;y;v;o;o;o;o;n;n;n;n;b;b;b;b;b;b;n;n;b;b;n;|];
+  [|t;t;t;t;t;t;n;n;o;v;y;o;y;o;o;o;o;o;o;n;n;n;b;b;b;b;b;n;n;b;b;n;|];
+  [|t;t;t;t;t;t;n;o;y;y;o;o;v;o;o;o;o;o;o;o;n;n;n;b;b;b;n;n;n;b;n;t;|];
+  [|t;t;t;t;t;n;n;v;o;v;o;o;o;o;o;o;o;o;o;o;o;n;n;n;b;n;n;n;n;b;n;t;|];
+  [|t;t;t;t;t;n;v;o;o;v;o;o;o;o;o;o;o;o;o;o;o;o;n;n;n;n;n;n;n;n;t;t;|];
+  [|t;t;t;t;n;n;o;o;o;o;o;o;o;o;o;o;o;o;o;o;o;n;n;n;n;n;n;t;t;t;t;t;|];
+  [|t;t;t;t;n;o;o;o;o;o;o;o;o;o;o;o;o;o;o;o;n;n;t;t;t;t;t;t;t;t;t;t;|];
+  [|t;t;t;t;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;|];
+|];;
+
+(*
+let x = ref 0 and y = ref 0;;
+let bg = get_image !x !y 32 32;;
+while true do
+  let st = wait_next_event [Mouse_motion; Button_down] in
+  if not st.button then draw_image bg !x !y;
+  x := st.mouse_x;
+  y := st.mouse_y;
+  blit_image bg !x !y;
+  draw_image caml !x !y;
+done;;
+*)
+set_color (rgb 0 0 0);
+remember_mode false;
+try while true do
+  let st = wait_next_event [Mouse_motion; Button_down; Key_pressed] in
+  synchronize ();
+  if st.keypressed then raise Exit;
+  if st.button then begin
+    remember_mode true;
+    draw_image caml st.mouse_x st.mouse_y;
+    remember_mode false;
+  end;
+  let x = st.mouse_x + 16 and y = st.mouse_y + 16 in
+
+  moveto 0 y;
+  lineto (x - 25) y;
+  moveto 10000 y;
+  lineto (x + 25) y;
+
+  moveto x 0;
+  lineto x (y - 25);
+  moveto x 10000;
+  lineto x (y + 25);
+
+  draw_image caml st.mouse_x st.mouse_y;
+done with Exit -> ()
+;;
+
+(* To run this example:
+   ********************
+   1. Select all the text in this window.
+   2. Drag it to the toplevel window.
+   3. Watch the colors.
+   4. Drag the mouse over the graphics window and click here and there.
+   5. Type any key to the graphics window to stop the program.
+*)
diff --git a/test/Moretest/graph_test.ml b/test/Moretest/graph_test.ml
new file mode 100644
index 00000000..cd4c0813
--- /dev/null
+++ b/test/Moretest/graph_test.ml
@@ -0,0 +1,288 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Pierre Weis, 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.  *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* graph_test.ml : tests various drawing and filling primitives of the
+   Graphics library. *)
+
+(* To run this example just load this file into a suitable toplevel.
+   Alternatively execute
+   ocamlc graphics.cma graph_test.ml *)
+
+open Graphics;;
+
+auto_synchronize false;;
+display_mode false;;
+remember_mode true;;
+
+let sz = 450;;
+
+open_graph (Printf.sprintf " %ix%i" sz sz);;
+
+(* To be defined for older versions of O'Caml
+   Lineto, moveto and draw_rect.
+
+let rlineto x y =
+ let xc, yc = current_point () in
+ lineto (x + xc) (y + yc);;
+
+let rmoveto x y =
+ let xc, yc = current_point () in
+ moveto (x + xc) (y + yc);;
+
+let draw_rect x y w h =
+ let x0, y0 = current_point () in
+ moveto x y;
+ rlineto w 0;
+ rlineto 0 h;
+ rlineto (- w) 0;
+ rlineto 0 (-h);
+ moveto x0 y0;;
+*)
+
+(* A set of points. *)
+
+set_color foreground;;
+
+let dashes y =
+ for i = 1 to 100 do
+  plot y (2 * i);
+  plot y (3 * i);
+  plot y (4 * i);
+ done;;
+
+dashes 3;;
+
+set_line_width 20;;
+dashes (sz - 20);;
+
+(* Drawing chars *)
+
+draw_char 'C';
+draw_char 'a';
+draw_char 'm';
+draw_char 'l';;
+
+(* More and more red enlarging squares *)
+moveto 10 10;;
+set_line_width 5;;
+
+let carre c =
+ rlineto 0 c;
+ rlineto c 0;
+ rlineto 0 (- c);
+ rlineto (- c) 0;;
+
+for i = 1 to 10 do
+ moveto (10 * i) (10 * i);
+ set_color (rgb (155 + 10 * i) 0 0);
+ carre (10 * i)
+done;;
+
+(* Blue squares in arithmetic progression *)
+moveto 10 210;;
+set_color blue;;
+set_line_width 1;;
+
+for i = 1 to 10 do
+ carre (10 * i)
+done;;
+
+(* Tiny circles filled or not *)
+rmoveto 0 120;;
+(* Must not change the current point *)
+fill_circle 20 190 10;;
+set_color green;;
+rlineto 0 10;;
+rmoveto 50 10;;
+let x, y = current_point () in
+(* Must not change the current point *)
+draw_circle x y 20;;
+set_color black;;
+rlineto 0 20;;
+
+(* Cyan rectangles as a kind of graphical representation *)
+set_color cyan;;
+
+let lw = 15;;
+set_line_width lw;;
+let go_caption l = moveto 210 (130 - lw + l);;
+let go_legend () = go_caption (- 3 * lw);;
+
+go_caption 0;;
+fill_rect 210 130 5 10;;
+fill_rect 220 130 10 20;;
+fill_rect 235 130 15 40;;
+fill_rect 255 130 20 80;;
+fill_rect 280 130 25 160;;
+(* A green rectangle below the graph. *)
+set_color green;;
+rlineto 50 0;;
+
+(* A black frame for each of our rectangles *)
+set_color black;;
+set_line_width (lw / 4);;
+
+draw_rect 210 130 5 10;;
+draw_rect 220 130 10 20;;
+draw_rect 235 130 15 40;;
+draw_rect 255 130 20 80;;
+draw_rect 280 130 25 160;;
+
+(* A black rectangle after the green one, below the graph. *)
+set_line_width lw;;
+rlineto 50 0;;
+
+(* Write a text in yellow on a blue background. *)
+(* x = 210, y = 70 *)
+go_legend ();;
+set_text_size 10;;
+set_color (rgb 150 100 250);;
+let x,y = current_point () in
+fill_rect x (y - 5) (8 * 20) 25;;
+set_color yellow;;
+go_legend ();;
+draw_string "Graphics (Caml)";;
+
+(* Pie parts in different colors. *)
+let draw_green_string s = set_color green; draw_string s;;
+let draw_red_string s = set_color red; draw_string s;;
+
+moveto 120 210;;
+set_color red;;
+fill_arc 150 260 25 25 60 300;
+draw_green_string "A ";
+draw_red_string "red";
+draw_green_string " pie.";
+
+set_text_size 5;
+moveto 180 240;
+draw_red_string "A "; draw_green_string "green"; draw_red_string " slice.";;
+set_color green;
+fill_arc 200 260 25 25 0 60;
+set_color black;
+set_line_width 2;
+draw_arc 200 260 27 27 0 60;;
+
+(* Should do nothing since this is a line *)
+set_color red;;
+fill_poly [| (40, 10); (150, 70); (150, 10); (40, 10) |];;
+set_color blue;;
+
+(* Drawing polygones. *)
+(* Redefining the draw_poly primitive for the usual library. *)
+let draw_poly v =
+ let l = Array.length v in
+  if l > 0 then begin
+  let x0, y0 = current_point () in
+  let p0 = v.(0) in
+  let x, y = p0 in moveto x y;
+  for i = 1 to l - 1 do
+   let x, y = v.(i) in lineto x y
+  done;
+  lineto x y;
+  moveto x0 y0
+ end;;
+
+draw_poly [| (150, 10); (150, 70); (260, 10); (150, 10) |];;
+
+(* Filling polygones. *)
+(* Two equilateral triangles, one red and one blue, and their inside
+   filled in black. *)
+let equi x y l =
+ [| (x - l / 2, y);
+    (x, y + int_of_float (float_of_int l *. (sqrt 3.0 /. 2.0)));
+    (x + l / 2, y) |];;
+
+set_color black;;
+fill_poly (Array.append (equi 300 20 40) (equi 300 44 (- 40)));;
+
+set_line_width 1;;
+set_color cyan;;
+draw_poly (equi 300 20 40);;
+set_color red;;
+draw_poly (equi 300 44 (- 40));;
+
+(* Drawing and filling ellipses. *)
+let x, y = current_point () in
+rlineto 10 10; moveto x y;
+
+moveto 395 100;;
+
+let x, y = current_point () in
+fill_ellipse x y 25 15;;
+
+set_color (rgb 0xFF 0x00 0xFF);;
+rmoveto 0 (- 50);;
+
+let x, y = current_point () in
+fill_ellipse x y 15 30;;
+
+rmoveto (- 45) 0;;
+let x, y = current_point () in
+draw_ellipse x y 25 10;;
+
+(* Drawing and filling arcs. *)
+
+let draw_arc_ellipse x y r1 r2 =
+  set_color green;
+  draw_arc x y r1 r2 60 120;
+  set_color black;
+  draw_arc x y r1 r2 120 420;;
+
+set_line_width 3;;
+
+let draw_arc_ellipses x y r1 r2 =
+  let step = 5 in
+  for i = 0 to (r1 - step) / (2 * step) do
+   for j = 0 to (r2 - step) / (2 * step) do
+    draw_arc_ellipse x y (3 * i * step) (3 * j * step)
+   done
+  done;;
+
+draw_arc_ellipses 20 128 15 50;;
+
+let fill_arc_ellipse x y r1 r2 c1 c2 =
+  set_color c1;
+  fill_arc x y r1 r2 60 120;
+  set_color c2;
+  fill_arc x y r1 r2 120 420;;
+
+let fill_arc_ellipses x y r1 r2 =
+  let step = 3 in
+  let c1 = ref black
+  and c2 = ref yellow in
+  let exchange r1 r2 = let tmp = !r1 in r1 := !r2; r2 := tmp in
+  for i = r1 / (2 * step) downto 10 do
+   for j = r2 / (2 * step) downto 30 do
+    exchange c1 c2;
+    fill_arc_ellipse x y (3 * i) (3 * j) !c1 !c2
+   done
+  done;;
+
+fill_arc_ellipses 400 240 150 200;;
+
+
+synchronize ();;
+
+(* transparent color drawing *)
+set_color transp;;
+draw_circle 400 240 50;;
+draw_circle 400 240 40;;
+draw_circle 400 240 30;;
+(* try to go back a normal color *)
+set_color red;;
+draw_circle 400 240 20;;
+
+synchronize ();;
+
+input_line stdin;;
diff --git a/test/Moretest/includestruct.ml b/test/Moretest/includestruct.ml
new file mode 100644
index 00000000..182272c1
--- /dev/null
+++ b/test/Moretest/includestruct.ml
@@ -0,0 +1,92 @@
+(* Test for "include <module-expr>" inside structures *)
+
+module A =
+  struct
+    type t = int
+    let x = (1 : t)
+    let y = (2 : t)
+    let f (z : t) = (x + z : t)
+  end
+
+module B =
+  struct
+    include A
+    type u = t * t
+    let p = ((x, y) : u)
+    let g ((x, y) : u) = ((f x, f y) : u)
+  end
+
+let _ =
+  let print_pair (x,y) =
+    print_int x; print_string ", "; print_int y; print_newline() in
+  print_pair B.p;
+  print_pair (B.g B.p);
+  print_pair (B.g (123, 456))
+
+module H =
+  struct
+    include A
+    let f (z : t) = (x - 1 : t)
+  end
+
+let _ =
+  print_int (H.f H.x); print_newline()
+
+module C =
+  struct
+    include (A : sig type t val f : t -> int val x : t end)
+    let z = f x
+  end
+
+let _ =
+  print_int C.z; print_newline();
+  print_int (C.f C.x); print_newline()
+
+(* Toplevel inclusion *)
+
+include A
+
+let _ =
+  print_int x; print_newline();
+  print_int (f y); print_newline()
+
+(* With a functor *)
+
+module F(X: sig end) =
+  struct
+    let _ = print_string "F is called"; print_newline()
+    type t = A | B of int
+    let print_t = function A -> print_string "A"
+                         | B x -> print_int x
+  end
+
+module D =
+  struct
+    include F(struct end)
+    let test() = print_t A; print_newline(); print_t (B 42); print_newline()
+  end
+    
+let _ =
+  D.test();
+  D.print_t D.A; print_newline(); D.print_t (D.B 42); print_newline()
+
+(* Exceptions and classes *)
+
+module E =
+  struct
+    exception Exn of string
+    class c = object method m = 1 end
+  end
+
+module G =
+  struct
+    include E
+    let _ =
+      begin try raise (Exn "foo") with Exn s -> print_string s end;
+      print_int ((new c)#m); print_newline()
+  end
+
+let _ =
+  begin try raise (G.Exn "foo") with G.Exn s -> print_string s end;
+  print_int ((new G.c)#m); print_newline()
+
diff --git a/test/Moretest/intext.ml b/test/Moretest/intext.ml
new file mode 100644
index 00000000..048b319f
--- /dev/null
+++ b/test/Moretest/intext.ml
@@ -0,0 +1,454 @@
+(* Test for output_value / input_value *)
+
+type t = A | B of int | C of float | D of string | E of char
+       | F of t | G of t * t | H of int * t | I of t * float | J
+
+let longstring =
+"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
+let verylongstring =
+"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
+ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
+ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
+ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
+ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
+ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
+ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\
+ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
+
+let bigint = Int64.to_int 0x123456789ABCDEF0L
+
+let rec fib n =
+  if n < 2 then 1 else fib(n-1) + fib(n-2)
+
+let test_out filename =
+  let oc = open_out_bin filename in
+  output_value oc 1;
+  output_value oc (-1);
+  output_value oc 258;
+  output_value oc 20000;
+  output_value oc 0x12345678;
+  output_value oc bigint;
+  output_value oc "foobargeebuz";
+  output_value oc longstring;
+  output_value oc verylongstring;
+  output_value oc 3.141592654;
+  output_value oc ();
+  output_value oc A;
+  output_value oc (B 1);
+  output_value oc (C 2.718);
+  output_value oc (D "hello, world!");
+  output_value oc (E 'l');
+  output_value oc (F(B 1));
+  output_value oc (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e')))));
+  output_value oc (H(1, A));
+  output_value oc (I(B 2, 1e-6));
+  let x = D "sharing" in
+  let y = G(x, x) in
+  let z = G(y, G(x, y)) in
+  output_value oc z;
+  output_value oc [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|];
+  let rec big n = if n <= 0 then A else H(n, big(n-1)) in
+  output_value oc (big 1000);
+  Marshal.to_channel oc y [Marshal.No_sharing];
+  Marshal.to_channel oc fib [Marshal.Closures];
+  output_value oc (Int32.of_string "0");
+  output_value oc (Int32.of_string "123456");
+  output_value oc (Int32.of_string "-123456");
+  output_value oc (Int64.of_string "0");
+  output_value oc (Int64.of_string "123456789123456");
+  output_value oc (Int64.of_string "-123456789123456");
+  output_value oc (Nativeint.of_string "0");
+  output_value oc (Nativeint.of_string "123456");
+  output_value oc (Nativeint.of_string "-123456");
+  output_value oc (Nativeint.shift_left (Nativeint.of_string "123456789") 32);
+  output_value oc (Nativeint.shift_left (Nativeint.of_string "-123456789") 32);
+  let i = Int64.of_string "123456789123456" in output_value oc (i,i);
+  close_out oc
+
+
+let test n b =
+  prerr_string "Test "; prerr_int n;
+  if b then prerr_string " passed.\n" else prerr_string " FAILED.\n";
+  flush stderr
+
+let test_in filename =
+  let ic = open_in_bin filename in
+  test 1 (input_value ic = 1);
+  test 2 (input_value ic = (-1));
+  test 3 (input_value ic = 258);
+  test 4 (input_value ic = 20000);
+  test 5 (input_value ic = 0x12345678);
+  test 6 (input_value ic = bigint);
+  test 7 (input_value ic = "foobargeebuz");
+  test 8 (input_value ic = longstring);
+  test 9 (input_value ic = verylongstring);
+  test 10 (input_value ic = 3.141592654);
+  test 11 (input_value ic = ());
+  test 12 (match input_value ic with
+    A -> true
+  | _ -> false);
+  test 13 (match input_value ic with
+    (B 1) -> true
+  | _ -> false);
+  test 14 (match input_value ic with
+    (C f) -> f = 2.718
+  | _ -> false);
+  test 15 (match input_value ic with
+    (D "hello, world!") -> true
+  | _ -> false);
+  test 16 (match input_value ic with
+    (E 'l') -> true
+  | _ -> false);
+  test 17 (match input_value ic with
+    (F(B 1)) -> true
+  | _ -> false);
+  test 18 (match input_value ic with
+    (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true
+  | _ -> false);
+  test 19 (match input_value ic with
+    (H(1, A)) -> true
+  | _ -> false);
+  test 20 (match input_value ic with
+    (I(B 2, 1e-6)) -> true
+  | _ -> false);
+  test 21 (match input_value ic with
+    G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) ->
+      t1 == t2 && t3 == t5 && t4 == t1
+  | _ -> false);
+  test 22 (input_value ic = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]);
+  let rec check_big n t =
+    if n <= 0 then
+      test 23 (match t with A -> true | _ -> false)
+    else
+      match t with H(m, s) -> if m = n then check_big (n-1) s
+                                       else test 23 false
+                 | _ -> test 23 false
+  in
+    check_big 1000 (input_value ic);
+  test 24 (match input_value ic with
+    G((D "sharing" as t1), (D "sharing" as t2)) -> t1 != t2
+  | _ -> false);
+  test 25 (let fib = input_value ic in fib 5 = 8 && fib 10 = 89);
+  test 26 (input_value ic = Int32.of_string "0");
+  test 27 (input_value ic = Int32.of_string "123456");
+  test 28 (input_value ic = Int32.of_string "-123456");
+  test 29 (input_value ic = Int64.of_string "0");
+  test 30 (input_value ic = Int64.of_string "123456789123456");
+  test 31 (input_value ic = Int64.of_string "-123456789123456");
+  test 32 (input_value ic = Nativeint.of_string "0");
+  test 33 (input_value ic = Nativeint.of_string "123456");
+  test 34 (input_value ic = Nativeint.of_string "-123456");
+  test 35 (input_value ic =
+             Nativeint.shift_left (Nativeint.of_string "123456789") 32);
+  test 36 (input_value ic =
+             Nativeint.shift_left (Nativeint.of_string "-123456789") 32);
+  let ((i, j) : int64 * int64) = input_value ic in
+  test 37 (i = Int64.of_string "123456789123456");
+  test 38 (j = Int64.of_string "123456789123456");
+  test 39 (i == j);
+  close_in ic
+
+let test_string () =
+  let s = Marshal.to_string 1 [] in
+  test 101 (Marshal.from_string s 0 = 1);
+  let s = Marshal.to_string (-1) [] in
+  test 102 (Marshal.from_string s 0 = (-1));
+  let s = Marshal.to_string 258 [] in
+  test 103 (Marshal.from_string s 0 = 258);
+  let s = Marshal.to_string 20000 [] in
+  test 104 (Marshal.from_string s 0 = 20000);
+  let s = Marshal.to_string 0x12345678 [] in
+  test 105 (Marshal.from_string s 0 = 0x12345678);
+  let s = Marshal.to_string bigint [] in
+  test 106 (Marshal.from_string s 0 = bigint);
+  let s = Marshal.to_string "foobargeebuz" [] in
+  test 107 (Marshal.from_string s 0 = "foobargeebuz");
+  let s = Marshal.to_string longstring [] in
+  test 108 (Marshal.from_string s 0 = longstring);
+  let s = Marshal.to_string verylongstring [] in
+  test 109 (Marshal.from_string s 0 = verylongstring);
+  let s = Marshal.to_string 3.141592654 [] in
+  test 110 (Marshal.from_string s 0 = 3.141592654);
+  let s = Marshal.to_string () [] in
+  test 111 (Marshal.from_string s 0 = ());
+  let s = Marshal.to_string A [] in
+  test 112 (match Marshal.from_string s 0 with
+    A -> true
+  | _ -> false);
+  let s = Marshal.to_string (B 1) [] in
+  test 113 (match Marshal.from_string s 0 with
+    (B 1) -> true
+  | _ -> false);
+  let s = Marshal.to_string (C 2.718) [] in
+  test 114 (match Marshal.from_string s 0 with
+    (C f) -> f = 2.718
+  | _ -> false);
+  let s = Marshal.to_string (D "hello, world!") [] in
+  test 115 (match Marshal.from_string s 0 with
+    (D "hello, world!") -> true
+  | _ -> false);
+  let s = Marshal.to_string (E 'l') [] in
+  test 116 (match Marshal.from_string s 0 with
+    (E 'l') -> true
+  | _ -> false);
+  let s = Marshal.to_string (F(B 1)) [] in
+  test 117 (match Marshal.from_string s 0 with
+    (F(B 1)) -> true
+  | _ -> false);
+  let s = Marshal.to_string (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [] in
+  test 118 (match Marshal.from_string s 0 with
+    (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true
+  | _ -> false);
+  let s = Marshal.to_string (H(1, A)) [] in
+  test 119 (match Marshal.from_string s 0 with
+    (H(1, A)) -> true
+  | _ -> false);
+  let s = Marshal.to_string (I(B 2, 1e-6)) [] in
+  test 120 (match Marshal.from_string s 0 with
+    (I(B 2, 1e-6)) -> true
+  | _ -> false);
+  let x = D "sharing" in
+  let y = G(x, x) in
+  let z = G(y, G(x, y)) in
+  let s = Marshal.to_string z [] in
+  test 121 (match Marshal.from_string s 0 with
+    G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) ->
+      t1 == t2 && t3 == t5 && t4 == t1
+  | _ -> false);
+  let s = Marshal.to_string [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] [] in
+  test 122 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]);
+  let rec big n = if n <= 0 then A else H(n, big(n-1)) in
+  let s = Marshal.to_string (big 1000) [] in
+  let rec check_big n t =
+    if n <= 0 then
+      test 123 (match t with A -> true | _ -> false)
+    else
+      match t with H(m, s) -> if m = n then check_big (n-1) s
+                                       else test 123 false
+                 | _ -> test 123 false
+  in
+    check_big 1000 (Marshal.from_string s 0)
+
+let test_buffer () =
+  let s = String.create 512 in
+  Marshal.to_buffer s 0 512 1 [];
+  test 201 (Marshal.from_string s 0 = 1);
+  Marshal.to_buffer s 0 512 (-1) [];
+  test 202 (Marshal.from_string s 0 = (-1));
+  Marshal.to_buffer s 0 512 258 [];
+  test 203 (Marshal.from_string s 0 = 258);
+  Marshal.to_buffer s 0 512 20000 [];
+  test 204 (Marshal.from_string s 0 = 20000);
+  Marshal.to_buffer s 0 512 0x12345678 [];
+  test 205 (Marshal.from_string s 0 = 0x12345678);
+  Marshal.to_buffer s 0 512 bigint [];
+  test 206 (Marshal.from_string s 0 = bigint);
+  Marshal.to_buffer s 0 512 "foobargeebuz" [];
+  test 207 (Marshal.from_string s 0 = "foobargeebuz");
+  Marshal.to_buffer s 0 512 longstring [];
+  test 208 (Marshal.from_string s 0 = longstring);
+  test 209
+    (try Marshal.to_buffer s 0 512 verylongstring []; false
+     with Failure "Marshal.to_buffer: buffer overflow" -> true);
+  Marshal.to_buffer s 0 512 3.141592654 [];
+  test 210 (Marshal.from_string s 0 = 3.141592654);
+  Marshal.to_buffer s 0 512 () [];
+  test 211 (Marshal.from_string s 0 = ());
+  Marshal.to_buffer s 0 512 A [];
+  test 212 (match Marshal.from_string s 0 with
+    A -> true
+  | _ -> false);
+  Marshal.to_buffer s 0 512 (B 1) [];
+  test 213 (match Marshal.from_string s 0 with
+    (B 1) -> true
+  | _ -> false);
+  Marshal.to_buffer s 0 512 (C 2.718) [];
+  test 214 (match Marshal.from_string s 0 with
+    (C f) -> f = 2.718
+  | _ -> false);
+  Marshal.to_buffer s 0 512 (D "hello, world!") [];
+  test 215 (match Marshal.from_string s 0 with
+    (D "hello, world!") -> true
+  | _ -> false);
+  Marshal.to_buffer s 0 512 (E 'l') [];
+  test 216 (match Marshal.from_string s 0 with
+    (E 'l') -> true
+  | _ -> false);
+  Marshal.to_buffer s 0 512 (F(B 1)) [];
+  test 217 (match Marshal.from_string s 0 with
+    (F(B 1)) -> true
+  | _ -> false);
+  Marshal.to_buffer s 0 512 (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [];
+  test 218 (match Marshal.from_string s 0 with
+    (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true
+  | _ -> false);
+  Marshal.to_buffer s 0 512 (H(1, A)) [];
+  test 219 (match Marshal.from_string s 0 with
+    (H(1, A)) -> true
+  | _ -> false);
+  Marshal.to_buffer s 0 512 (I(B 2, 1e-6)) [];
+  test 220 (match Marshal.from_string s 0 with
+    (I(B 2, 1e-6)) -> true
+  | _ -> false);
+  let x = D "sharing" in
+  let y = G(x, x) in
+  let z = G(y, G(x, y)) in
+  Marshal.to_buffer s 0 512 z [];
+  test 221 (match Marshal.from_string s 0 with
+    G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) ->
+      t1 == t2 && t3 == t5 && t4 == t1
+  | _ -> false);
+  Marshal.to_buffer s 0 512 [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] [];
+  test 222 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]);
+  let rec big n = if n <= 0 then A else H(n, big(n-1)) in
+  test 223
+    (try Marshal.to_buffer s 0 512 (big 1000) []; false
+     with Failure "Marshal.to_buffer: buffer overflow" -> true)
+
+let test_size() =
+  let s = Marshal.to_string (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [] in
+  test 300 (Marshal.header_size + Marshal.data_size s 0 = String.length s)
+
+external marshal_to_block
+   : string -> int -> 'a -> Marshal.extern_flags list -> unit
+   = "marshal_to_block"
+external marshal_from_block : string -> int -> 'a = "marshal_from_block"
+external static_alloc : int -> string = "static_alloc"
+
+let test_block () =
+  let s = static_alloc 512 in
+  marshal_to_block s 512 1 [];
+  test 401 (marshal_from_block s 512 = 1);
+  marshal_to_block s 512 (-1) [];
+  test 402 (marshal_from_block s 512 = (-1));
+  marshal_to_block s 512 258 [];
+  test 403 (marshal_from_block s 512 = 258);
+  marshal_to_block s 512 20000 [];
+  test 404 (marshal_from_block s 512 = 20000);
+  marshal_to_block s 512 0x12345678 [];
+  test 405 (marshal_from_block s 512 = 0x12345678);
+  marshal_to_block s 512 bigint [];
+  test 406 (marshal_from_block s 512 = bigint);
+  marshal_to_block s 512 "foobargeebuz" [];
+  test 407 (marshal_from_block s 512 = "foobargeebuz");
+  marshal_to_block s 512 longstring [];
+  test 408 (marshal_from_block s 512 = longstring);
+  test 409
+    (try marshal_to_block s 512 verylongstring []; false
+     with Failure "Marshal.to_buffer: buffer overflow" -> true);
+  marshal_to_block s 512 3.141592654 [];
+  test 410 (marshal_from_block s 512 = 3.141592654);
+  marshal_to_block s 512 () [];
+  test 411 (marshal_from_block s 512 = ());
+  marshal_to_block s 512 A [];
+  test 412 (match marshal_from_block s 512 with
+    A -> true
+  | _ -> false);
+  marshal_to_block s 512 (B 1) [];
+  test 413 (match marshal_from_block s 512 with
+    (B 1) -> true
+  | _ -> false);
+  marshal_to_block s 512 (C 2.718) [];
+  test 414 (match marshal_from_block s 512 with
+    (C f) -> f = 2.718
+  | _ -> false);
+  marshal_to_block s 512 (D "hello, world!") [];
+  test 415 (match marshal_from_block s 512 with
+    (D "hello, world!") -> true
+  | _ -> false);
+  marshal_to_block s 512 (E 'l') [];
+  test 416 (match marshal_from_block s 512 with
+    (E 'l') -> true
+  | _ -> false);
+  marshal_to_block s 512 (F(B 1)) [];
+  test 417 (match marshal_from_block s 512 with
+    (F(B 1)) -> true
+  | _ -> false);
+  marshal_to_block s 512 (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [];
+  test 418 (match marshal_from_block s 512 with
+    (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true
+  | _ -> false);
+  marshal_to_block s 512 (H(1, A)) [];
+  test 419 (match marshal_from_block s 512 with
+    (H(1, A)) -> true
+  | _ -> false);
+  marshal_to_block s 512 (I(B 2, 1e-6)) [];
+  test 420 (match marshal_from_block s 512 with
+    (I(B 2, 1e-6)) -> true
+  | _ -> false);
+  let x = D "sharing" in
+  let y = G(x, x) in
+  let z = G(y, G(x, y)) in
+  marshal_to_block s 512 z [];
+  test 421 (match marshal_from_block s 512 with
+    G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) ->
+      t1 == t2 && t3 == t5 && t4 == t1
+  | _ -> false);
+  marshal_to_block s 512 [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] [];
+  test 422 (marshal_from_block s 512 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]);
+  let rec big n = if n <= 0 then A else H(n, big(n-1)) in
+  test 423
+    (try marshal_to_block s 512 (big 1000) []; false
+     with Failure _ -> true);
+  test 424
+    (try marshal_to_block s 512 "Hello, world!" [];
+         marshal_from_block s 8;
+         false
+     with Failure _ -> true)
+
+(* Test for really big objects *)
+
+let counter = ref 0
+
+let rec make_big n =
+  if n <= 0 then begin
+    incr counter; B !counter
+  end else begin
+    let l = make_big (n-1) in
+    let r = make_big (n-1) in
+    G(l, r)
+  end
+
+let rec check_big n x =
+  if n <= 0 then begin
+    match x with
+      B k -> incr counter; k = !counter
+    | _   -> false
+  end else begin
+    match x with
+      G(l, r) -> check_big (n-1) l && check_big (n-1) r
+    | _       -> false
+  end
+
+let main() =
+  if Array.length Sys.argv <= 2 then begin
+    test_out "intext.data"; test_in "intext.data";
+    test_out "intext.data"; test_in "intext.data";
+    Sys.remove "intext.data";
+    test_string();
+    test_buffer();
+    test_size();
+    test_block()
+  end else
+  if Sys.argv.(1) = "make" then begin
+    let n = int_of_string Sys.argv.(2) in
+    let oc = open_out_bin "intext.data" in
+    counter := 0;
+    output_value oc (make_big n);
+    close_out oc
+  end else
+  if Sys.argv.(1) = "test" then begin
+    let n = int_of_string Sys.argv.(2) in
+    let ic = open_in_bin "intext.data" in
+    let b = (input_value ic : t) in
+    Gc.full_major();
+    close_in ic;
+    counter := 0;
+    if check_big n b then
+      Printf.printf "Test big %d passed" n
+    else
+      Printf.printf "Test big %d FAILED" n;
+    print_newline()
+  end
+
+let _ = Printexc.catch main (); exit 0
diff --git a/test/Moretest/intextaux.c b/test/Moretest/intextaux.c
new file mode 100644
index 00000000..9225b90b
--- /dev/null
+++ b/test/Moretest/intextaux.c
@@ -0,0 +1,13 @@
+#include <mlvalues.h>
+#include <intext.h>
+
+value marshal_to_block(value vbuf, value vlen, value v, value vflags)
+{
+  return Val_long(output_value_to_block(v, vflags, 
+                                        (char *) vbuf, Long_val(vlen)));
+}
+
+value marshal_from_block(value vbuf, value vlen)
+{
+  return input_value_from_block((char *) vbuf, Long_val(vlen));
+}
diff --git a/test/Moretest/io.ml b/test/Moretest/io.ml
new file mode 100644
index 00000000..2fb2c999
--- /dev/null
+++ b/test/Moretest/io.ml
@@ -0,0 +1,101 @@
+(* Test a file copy function *)
+
+let test msg funct f1 f2 =
+  print_string msg; print_newline();
+  funct f1 f2;
+  if Sys.command ("cmp " ^ f1 ^ " " ^ f2) = 0
+  then print_string "passed"
+  else print_string "FAILED";
+  print_newline()
+
+(* File copy with constant-sized chunks *)
+
+let copy_file sz infile ofile =
+  let ic = open_in infile in
+  let oc = open_out ofile in
+  let buffer = String.create sz in
+  let rec copy () =
+    let n = input ic buffer 0 sz in
+    if n = 0 then () else begin
+      output oc buffer 0 n;
+      copy ()
+    end in
+  copy();
+  close_in ic;
+  close_out oc
+
+(* File copy with random-sized chunks *)
+
+let copy_random sz infile ofile =
+  let ic = open_in infile in
+  let oc = open_out ofile in
+  let buffer = String.create sz in
+  let rec copy () =
+    let s = 1 + Random.int sz in
+    let n = input ic buffer 0 s in
+    if n = 0 then () else begin
+      output oc buffer 0 n;
+      copy ()
+    end in
+  copy();
+  close_in ic;
+  close_out oc
+
+(* File copy line per line *)
+
+let copy_line infile ofile =
+  let ic = open_in infile in
+  let oc = open_out ofile in
+  try
+    while true do
+      output_string oc (input_line ic); output_char oc '\n'
+    done
+  with End_of_file ->
+    close_in ic;
+    close_out oc
+
+(* Backward copy, with lots of seeks *)
+
+let copy_seek chunksize infile ofile =
+  let ic = open_in_bin infile in
+  let oc = open_out_bin ofile in
+  let size = in_channel_length ic in
+  let buffer = String.create chunksize in
+  for i = (size - 1) / chunksize downto 0 do
+    seek_in ic (i * chunksize);
+    seek_out oc (i * chunksize);
+    let n = input ic buffer 0 chunksize in
+    output oc buffer 0 n
+  done;
+  close_in ic;
+  close_out oc
+
+(* Create long lines of text *)
+
+let make_lines ofile =
+  let oc = open_out ofile in
+  for i = 1 to 256 do
+    output_string oc (String.make (i*64) '.'); output_char oc '\n'
+  done;
+  close_out oc
+
+(* The test *)
+
+let _ =
+  let src = Sys.argv.(1) in
+  test "16-byte chunks" (copy_file 16) src "/tmp/testio";
+  test "256-byte chunks" (copy_file 256) src "/tmp/testio";
+  test "4096-byte chunks" (copy_file 4096) src "/tmp/testio";
+  test "65536-byte chunks" (copy_file 65536) src "/tmp/testio";
+  test "19-byte chunks" (copy_file 19) src "/tmp/testio";
+  test "263-byte chunks" (copy_file 263) src "/tmp/testio";
+  test "4011-byte chunks" (copy_file 4011) src "/tmp/testio";
+  test "0...8192 byte chunks" (copy_random 8192) src "/tmp/testio";
+  test "line per line, short lines" copy_line "/etc/hosts" "/tmp/testio";
+  make_lines "/tmp/lines";
+  test "line per line, short and long lines" copy_line "/tmp/lines" "/tmp/testio";
+  test "backwards, 4096-byte chunks" (copy_seek 4096) src "/tmp/testio"; 
+  test "backwards, 64-byte chunks" (copy_seek 64) src "/tmp/testio"; 
+  Sys.remove "/tmp/lines";
+  Sys.remove "/tmp/testio";
+  exit 0
diff --git a/test/Moretest/manyargs.ml b/test/Moretest/manyargs.ml
new file mode 100644
index 00000000..0a1271ae
--- /dev/null
+++ b/test/Moretest/manyargs.ml
@@ -0,0 +1,18 @@
+let manyargs a b c d e f g h i j k =
+  print_string "a = "; print_int a; print_newline();
+  print_string "b = "; print_int b; print_newline();
+  print_string "c = "; print_int c; print_newline();
+  print_string "d = "; print_int d; print_newline();
+  print_string "e = "; print_int e; print_newline();
+  print_string "f = "; print_int f; print_newline();
+  print_string "g = "; print_int g; print_newline();
+  print_string "h = "; print_int h; print_newline();
+  print_string "i = "; print_int i; print_newline();
+  print_string "j = "; print_int j; print_newline();
+  print_string "k = "; print_int k; print_newline()
+
+let _ = manyargs 1 2 3 4 5 6 7 8 9 10 11
+
+external manyargs_ext: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "manyargs_argv" "manyargs"
+
+let _ = manyargs_ext 1 2 3 4 5 6 7 8 9 10 11
diff --git a/test/Moretest/manyargsprim.c b/test/Moretest/manyargsprim.c
new file mode 100644
index 00000000..c80e5346
--- /dev/null
+++ b/test/Moretest/manyargsprim.c
@@ -0,0 +1,24 @@
+#include "mlvalues.h"
+
+value manyargs(value a, value b, value c, value d, value e, value f,
+               value g, value h, value i, value j, value k)
+{
+  printf("a = %d\n", Int_val(a));
+  printf("b = %d\n", Int_val(b));
+  printf("c = %d\n", Int_val(c));
+  printf("d = %d\n", Int_val(d));
+  printf("e = %d\n", Int_val(e));
+  printf("f = %d\n", Int_val(f));
+  printf("g = %d\n", Int_val(g));
+  printf("h = %d\n", Int_val(h));
+  printf("i = %d\n", Int_val(i));
+  printf("j = %d\n", Int_val(j));
+  printf("k = %d\n", Int_val(k));
+  return Val_unit;
+}
+
+value manyargs_argv(value *argv, int argc)
+{
+  return manyargs(argv[0], argv[1], argv[2], argv[3], argv[4],
+                  argv[5], argv[6], argv[7], argv[8], argv[9], argv[10]);
+}
diff --git a/test/Moretest/md5.ml b/test/Moretest/md5.ml
new file mode 100644
index 00000000..46d8a10a
--- /dev/null
+++ b/test/Moretest/md5.ml
@@ -0,0 +1,219 @@
+(* Test int32 arithmetic and optimizations using the MD5 algorithm *)
+
+open Printf
+
+type context =
+  { buf: string;
+    mutable pos: int;
+    mutable a: int32;
+    mutable b: int32;
+    mutable c: int32;
+    mutable d: int32;
+    mutable bits: int64 }
+
+let step1 w x y z data s =
+  let w =
+    Int32.add (Int32.add w data)
+              (Int32.logxor z (Int32.logand x (Int32.logxor y z))) in
+  Int32.add x
+    (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s)))
+
+let step2 w x y z data s =
+  let w =
+    Int32.add (Int32.add w data)
+              (Int32.logxor y (Int32.logand z (Int32.logxor x y))) in
+  Int32.add x
+    (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s)))
+
+let step3 w x y z data s =
+  let w =
+    Int32.add (Int32.add w data)
+              (Int32.logxor x (Int32.logxor y z)) in
+  Int32.add x
+    (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s)))
+
+let step4 w x y z data s =
+  let w =
+    Int32.add (Int32.add w data)
+              (Int32.logxor y (Int32.logor x (Int32.logxor z (-1l)))) in
+  Int32.add x
+    (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s)))
+
+let transform ctx data =
+    let a = ctx.a and b = ctx.b and c = ctx.c and d = ctx.d in
+
+    let a = step1 a b c d (Int32.add data.(0) 0xd76aa478l) 7 in
+    let d = step1 d a b c (Int32.add data.(1) 0xe8c7b756l) 12 in
+    let c = step1 c d a b (Int32.add data.(2) 0x242070dbl) 17 in
+    let b = step1 b c d a (Int32.add data.(3) 0xc1bdceeel) 22 in
+    let a = step1 a b c d (Int32.add data.(4) 0xf57c0fafl) 7 in
+    let d = step1 d a b c (Int32.add data.(5) 0x4787c62al) 12 in
+    let c = step1 c d a b (Int32.add data.(6) 0xa8304613l) 17 in
+    let b = step1 b c d a (Int32.add data.(7) 0xfd469501l) 22 in
+    let a = step1 a b c d (Int32.add data.(8) 0x698098d8l) 7 in
+    let d = step1 d a b c (Int32.add data.(9) 0x8b44f7afl) 12 in
+    let c = step1 c d a b (Int32.add data.(10) 0xffff5bb1l) 17 in
+    let b = step1 b c d a (Int32.add data.(11) 0x895cd7bel) 22 in
+    let a = step1 a b c d (Int32.add data.(12) 0x6b901122l) 7 in
+    let d = step1 d a b c (Int32.add data.(13) 0xfd987193l) 12 in
+    let c = step1 c d a b (Int32.add data.(14) 0xa679438el) 17 in
+    let b = step1 b c d a (Int32.add data.(15) 0x49b40821l) 22 in
+
+    let a = step2 a b c d (Int32.add data.(1) 0xf61e2562l) 5 in
+    let d = step2 d a b c (Int32.add data.(6) 0xc040b340l) 9 in
+    let c = step2 c d a b (Int32.add data.(11) 0x265e5a51l) 14 in
+    let b = step2 b c d a (Int32.add data.(0) 0xe9b6c7aal) 20 in
+    let a = step2 a b c d (Int32.add data.(5) 0xd62f105dl) 5 in
+    let d = step2 d a b c (Int32.add data.(10) 0x02441453l) 9 in
+    let c = step2 c d a b (Int32.add data.(15) 0xd8a1e681l) 14 in
+    let b = step2 b c d a (Int32.add data.(4) 0xe7d3fbc8l) 20 in
+    let a = step2 a b c d (Int32.add data.(9) 0x21e1cde6l) 5 in
+    let d = step2 d a b c (Int32.add data.(14) 0xc33707d6l) 9 in
+    let c = step2 c d a b (Int32.add data.(3) 0xf4d50d87l) 14 in
+    let b = step2 b c d a (Int32.add data.(8) 0x455a14edl) 20 in
+    let a = step2 a b c d (Int32.add data.(13) 0xa9e3e905l) 5 in
+    let d = step2 d a b c (Int32.add data.(2) 0xfcefa3f8l) 9 in
+    let c = step2 c d a b (Int32.add data.(7) 0x676f02d9l) 14 in
+    let b = step2 b c d a (Int32.add data.(12) 0x8d2a4c8al) 20 in
+
+    let a = step3 a b c d (Int32.add data.(5) 0xfffa3942l) 4 in
+    let d = step3 d a b c (Int32.add data.(8) 0x8771f681l) 11 in
+    let c = step3 c d a b (Int32.add data.(11) 0x6d9d6122l) 16 in
+    let b = step3 b c d a (Int32.add data.(14) 0xfde5380cl) 23 in
+    let a = step3 a b c d (Int32.add data.(1) 0xa4beea44l) 4 in
+    let d = step3 d a b c (Int32.add data.(4) 0x4bdecfa9l) 11 in
+    let c = step3 c d a b (Int32.add data.(7) 0xf6bb4b60l) 16 in
+    let b = step3 b c d a (Int32.add data.(10) 0xbebfbc70l) 23 in
+    let a = step3 a b c d (Int32.add data.(13) 0x289b7ec6l) 4 in
+    let d = step3 d a b c (Int32.add data.(0) 0xeaa127fal) 11 in
+    let c = step3 c d a b (Int32.add data.(3) 0xd4ef3085l) 16 in
+    let b = step3 b c d a (Int32.add data.(6) 0x04881d05l) 23 in
+    let a = step3 a b c d (Int32.add data.(9) 0xd9d4d039l) 4 in
+    let d = step3 d a b c (Int32.add data.(12) 0xe6db99e5l) 11 in
+    let c = step3 c d a b (Int32.add data.(15) 0x1fa27cf8l) 16 in
+    let b = step3 b c d a (Int32.add data.(2) 0xc4ac5665l) 23 in
+
+    let a = step4 a b c d (Int32.add data.(0) 0xf4292244l) 6 in
+    let d = step4 d a b c (Int32.add data.(7) 0x432aff97l) 10 in
+    let c = step4 c d a b (Int32.add data.(14) 0xab9423a7l) 15 in
+    let b = step4 b c d a (Int32.add data.(5) 0xfc93a039l) 21 in
+    let a = step4 a b c d (Int32.add data.(12) 0x655b59c3l) 6 in
+    let d = step4 d a b c (Int32.add data.(3) 0x8f0ccc92l) 10 in
+    let c = step4 c d a b (Int32.add data.(10) 0xffeff47dl) 15 in
+    let b = step4 b c d a (Int32.add data.(1) 0x85845dd1l) 21 in
+    let a = step4 a b c d (Int32.add data.(8) 0x6fa87e4fl) 6 in
+    let d = step4 d a b c (Int32.add data.(15) 0xfe2ce6e0l) 10 in
+    let c = step4 c d a b (Int32.add data.(6) 0xa3014314l) 15 in
+    let b = step4 b c d a (Int32.add data.(13) 0x4e0811a1l) 21 in
+    let a = step4 a b c d (Int32.add data.(4) 0xf7537e82l) 6 in
+    let d = step4 d a b c (Int32.add data.(11) 0xbd3af235l) 10 in
+    let c = step4 c d a b (Int32.add data.(2) 0x2ad7d2bbl) 15 in
+    let b = step4 b c d a (Int32.add data.(9) 0xeb86d391l) 21 in
+
+    ctx.a <- Int32.add ctx.a a;
+    ctx.b <- Int32.add ctx.b b;
+    ctx.c <- Int32.add ctx.c c;
+    ctx.d <- Int32.add ctx.d d
+
+let string_to_data s =
+  let data = Array.make 16 0l in
+  for i = 0 to 15 do
+    let j = i lsl 2 in
+    data.(i) <-
+      Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+3])) 24)
+        (Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+2])) 16)
+          (Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+1])) 8)
+                       (Int32.of_int (Char.code s.[j]))))
+  done;
+  data
+
+let int32_to_string n s i =
+  s.[i+3] <- Char.chr (Int32.to_int (Int32.shift_right n 24) land 0xFF);
+  s.[i+2] <- Char.chr (Int32.to_int (Int32.shift_right n 16) land 0xFF);
+  s.[i+1] <- Char.chr (Int32.to_int (Int32.shift_right n 8) land 0xFF);
+  s.[i] <- Char.chr (Int32.to_int n land 0xFF)
+
+let init () =
+  { buf = String.create 64;
+    pos = 0;
+    a = 0x67452301l;
+    b = 0xefcdab89l;
+    c = 0x98badcfel;
+    d = 0x10325476l;
+    bits = 0L }
+
+let update ctx input ofs len =
+  let rec upd ofs len =
+    if len <= 0 then () else
+    if ctx.pos + len < 64 then begin
+      (* Just buffer the data *)
+      String.blit input ofs ctx.buf ctx.pos len;
+      ctx.pos <- ctx.pos + len
+    end else begin
+      (* Fill the buffer *)
+      let len' = 64 - ctx.pos in
+      if len' > 0 then String.blit input ofs ctx.buf ctx.pos len';
+      (* Transform 64 bytes *)
+      transform ctx (string_to_data ctx.buf);
+      ctx.pos <- 0;
+      upd (ofs + len') (len - len')
+    end in
+  upd ofs len;
+  ctx.bits <- Int64.add ctx.bits (Int64.of_int (len lsl 3))
+
+
+let finish ctx =
+  let padding = String.make 64 '\000' in
+  padding.[0] <- '\x80';
+  let numbits = ctx.bits in
+  if ctx.pos < 56 then begin
+    update ctx padding 0 (56 - ctx.pos)
+  end else begin
+    update ctx padding 0 (64 + 56 - ctx.pos)
+  end;
+  assert (ctx.pos = 56);
+  let data = string_to_data ctx.buf in
+  data.(14) <- (Int64.to_int32 numbits);
+  data.(15) <- (Int64.to_int32 (Int64.shift_right_logical numbits 32));
+  transform ctx data;
+  let res = String.create 16 in
+  int32_to_string ctx.a res 0;
+  int32_to_string ctx.b res 4;
+  int32_to_string ctx.c res 8;
+  int32_to_string ctx.d res 12;
+  res
+
+let test s =
+  let ctx = init() in
+  update ctx s 0 (String.length s);
+  let res = finish ctx in
+  let exp = Digest.string s in
+  let ok = (res = exp) in
+  if not ok then Printf.printf "Failure for '%s'\n" s;
+  ok
+
+let time msg iter fn =
+  let start = Sys.time() in
+  for i = 1 to iter do fn () done;
+  let stop = Sys.time() in
+  printf "%s: %.2f s\n" msg (stop -. start)
+
+let _ =
+  (* Test *)
+  if test ""
+  && test "a"
+  && test "abc"
+  && test "message digest"
+  && test "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+  then printf "Test vectors passed.\n";
+  flush stdout;
+  (* Benchmark *)
+  let s = String.make 50000 'a' in
+  let num_iter = 1000 in
+  time "Caml implementation" num_iter
+    (fun () ->
+      let ctx = init() in
+      update ctx s 0 (String.length s);
+      ignore (finish ctx));
+  time "C implementation" num_iter
+    (fun () -> ignore (Digest.string s))
diff --git a/test/Moretest/morematch.ml b/test/Moretest/morematch.ml
new file mode 100644
index 00000000..e6a0a1cb
--- /dev/null
+++ b/test/Moretest/morematch.ml
@@ -0,0 +1,1137 @@
+(**************************************************************)
+(*  This suite tests the pattern-matching compiler            *)
+(*  it should just compile and run.                           *)
+(*  While compiling the following messages are normal:        *)
+(**************************************************************)
+
+(*
+File "morematch.ml", line 38, characters 10-93:
+Warning: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+0
+File "morematch.ml", line 376, characters 2-15:
+Warning: this match case is unused.
+File "morematch.ml", line 443, characters 2-7:
+Warning: this match case is unused.
+*)
+
+let test msg f arg r =
+  if f arg <> r then begin
+    prerr_endline msg ;
+    failwith "Malaise"
+  end
+;;
+
+type t = A | B | C | D | E | F
+  ;;
+
+let f x = match x with
+| A | B | C -> 1
+| D | E -> 2
+| F -> 3;;
+
+test "un" f C 1 ;
+test "un" f D 2 ;
+test "un" f F 3 ; ()
+;;
+
+let g x = match x with
+  1 -> 1
+| 2 -> 2
+| 3 -> 3
+| 4 | 5 -> 4
+| 6 -> 5
+| 7 | 8 -> 6
+| 9 -> 7
+;;
+
+test "deux" g 5 4 ;
+test "deux" g 6 5 ;
+test "deux" g 9 7 ; ()
+;;
+
+  
+let g x = match x with
+  1 -> 1
+| 2 -> 2
+| 3 -> 3
+| 4 | 5 -> 4
+| 6 -> 5   
+| 7 | 8 -> 6
+| 9 -> 7
+| _ -> 8;;
+
+test "trois" g 10 8
+;;
+
+let g x= match  x with
+  1 -> 1
+| 2 -> 2
+| 3 -> 3
+| 4 | 5 -> 4
+| 6 -> 5   
+| 4|5|7 -> 100
+| 7 | 8 -> 6
+| 9 -> 7
+| _ -> 8;;
+test "quatre" g 4 4 ;
+test "quatre" g 7 100 ; ()
+;;
+
+
+let h x =
+ match x with
+   (1,1) -> 1
+| (2|3), 1 -> 2
+| 2,(2|3) -> 3
+| (4,4) -> 5
+| _ -> 100
+;;
+
+test "cinq" h (2,2) 3 ;
+test "cinq" h (2,1) 2 ;
+test "cinq" h (2,4) 100 ; ()
+;;
+
+(* idem hh (2,5) *)
+
+let hh x = match x with
+| 1,1 -> 1
+| 2,1 -> 2
+| (2|3),(1|2|3|4) -> 3
+| 2,5 -> 4
+| (4,4) -> 5
+| _ -> 100
+;;
+
+let hhh x = match x with
+| 1,1 -> 1
+| (2|3),1 -> 2
+| 2,2 -> 3
+| _ -> 100
+;;
+
+let h x =
+ match x with
+   (1,1) -> 1
+| 3,1 -> 2
+| 2,(2|3) -> 3
+| (4,4) -> 5
+| _ -> 100
+;;
+
+let h x = match x with
+  1 -> 1
+| 2|3 -> 2
+| 4 -> 4
+| 5 -> 5
+| 6|7 -> 6
+| 8 -> 8
+| _ -> 100
+;;
+let f x = match x with
+| ((1|2),(3|4))|((3|4),(1|2)) -> 1
+| (3,(5|6)) -> 2
+| _ -> 3
+;;
+
+test "six" f (1,3) 1 ;
+test "six" f (3,2) 1 ;
+test "six" f (3,5) 2 ;
+test "six" f (3,7) 3 ; ()
+;;
+
+type tt = {a : bool list ; b : bool}
+
+let f = function
+  | {a=([]|[true])} -> 1
+  | {a=false::_}|{b=(true|false)}    -> 2
+;;
+
+test "sept" f {a=[] ; b = true} 1 ;
+test "sept" f {a=[true] ; b = false} 1 ;
+test "sept" f {a=[false ; true] ; b = true} 2 ;
+test "sept" f {a=[false] ; b = false} 2 ; ()
+;;
+
+let f = function
+  | (([]|[true]),_) -> 1
+  | (false::_,_)|(_,(true|false)) -> 2
+;;
+
+test "huit" f ([],true) 1 ;
+test "huit" f ([true],false) 1 ;
+test "huit" f ([false ; true], true) 2 ;
+test "huit" f ([false], false) 2 ; ()
+;;
+
+
+let split_cases = function
+   | `Nil | `Cons _ as x -> `A x
+   | `Snoc _ as x -> `B x
+;;
+
+test "oubli" split_cases `Nil (`A `Nil);
+test "oubli" split_cases (`Cons 1) (`A (`Cons 1));
+test "oubli" split_cases (`Snoc 1) (`B (`Snoc 1)) ; ()
+;;
+
+type t1 = A of int | B of int
+let f1 = function
+  | (A x | B x) -> x
+;;
+
+test "neuf" f1 (A 1) 1 ;
+test "neuf" f1 (B 1) 1 ;
+;;
+
+type coucou = A of int | B of int * int | C
+;;
+
+
+let g = function
+  | (A x | B (_,x)) -> x
+  | C -> 0
+;;
+
+
+test "dix" g (A 1) 1 ;
+test "dix" g (B (1,2)) 2 ;
+;;
+
+
+
+let h = function
+  | ([x]|[1 ; x ]|[1 ; 2 ; x]) -> x
+  | _ -> 0
+;;
+
+test "encore" h [1] 1 ;
+test "encore" h [1;2] 2 ;
+test "encore" h [1;2;3] 3 ;
+test "encore" h [0 ; 0] 0 ; ()
+;;
+
+let f = function
+| (x,(0 as y)) | (y,x) -> y-x
+;;
+
+test "foo1" f (1,0) (-1);
+test "foo1" f (1,2) (-1)
+;;
+
+
+let f = function (([]|[_]) as x)|(_::([] as x))|(_::_::x)  -> x
+;;
+
+test "zob" f [] [] ;
+test "zob" f [1] [1] ;
+test "zob" f [1;2;3] [3]
+;;
+
+
+type zob = A | B | C | D of zob * int | E of zob * zob
+
+let rec f = function
+  | (A | B | C) -> A
+  | D (x,i) -> D (f x,i)
+  | E (x,_) -> D (f x,0)
+;;
+
+
+test "fin" f B A ;
+test "fin" f (D (C,1)) (D (A,1)) ;
+test "fin" f (E (C,A)) (D (A,0)) ; ()
+;;
+
+type length = 
+    Char of int | Pixel of int | Percent of int | No of string | Default
+
+let length = function
+  | Char n -> n | Pixel n -> n
+  | _       -> 0
+;;
+
+test "length" length (Char 10) 10 ;
+test "length" length (Pixel 20) 20 ;
+test "length" length Default 0 ;
+test "length" length (Percent 100) 0 ; ()
+;;
+
+let length2 = function
+  | Char n -> n | Percent n -> n
+  | _       -> 0
+;;
+
+test "length2" length2 (Char 10) 10 ;
+test "length2" length2 (Pixel 20) 0 ;
+test "length2" length2 Default 0 ;
+test "length2" length2(Percent 100) 100 ; ()
+;;
+
+let length3 = function
+  | Char _ | No _ -> true
+  | _ -> false
+;;
+
+test "length3" length3 (Char 10) true ;
+test "length3" length3 (No "") true ;
+test "length3" length3 (Pixel 20) false ;
+test "length3" length3 Default false ;
+test "length3" length3(Percent 100) false ; ()
+;;
+
+type hevea = A | B | C
+
+let h x = match x with
+| A -> 1
+| B|C -> 2
+;;
+
+test "hevea" h A 1 ;
+test "hevea" h B 2 ;
+test "hevea" h B 2 ; ()
+;;
+type lambda =
+    Lvar of int
+  | Lconst of int
+  | Lapply of lambda * lambda list
+  | Lfunction of bool  * int list * lambda
+  | Llet of  bool * int * lambda * lambda
+  | Lletrec of (int * lambda) list * lambda
+  | Lprim of string * lambda list
+  | Lswitch of lambda * lambda_switch
+  | Lstaticfail
+  | Lcatch of lambda * lambda
+  | Lstaticraise of int * lambda list
+  | Lstaticcatch of lambda * (int * int list) * lambda
+  | Ltrywith of lambda * int * lambda
+  | Lifthenelse of lambda * lambda * lambda
+  | Lsequence of lambda * lambda
+  | Lwhile of lambda * lambda
+  | Lfor of int * lambda * lambda * bool * lambda
+  | Lassign of int * lambda
+  | Lsend of lambda * lambda * lambda list
+  | Levent of lambda * lambda_event
+  | Lifused of int * 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_checked: bool ;                  (* True if bound checks needed *)
+    sw_nofail: bool}                    (* True if should not fail *)
+and lambda_event =
+  { lev_loc: int;
+    lev_kind: bool ;
+    lev_repr: int ref option;
+    lev_env: int list }
+
+let rec approx_present v l = true
+
+let rec lower_bind v arg lam = match lam with
+| Lifthenelse (cond, ifso, ifnot) -> 1
+| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw))
+    when not (approx_present v ls) -> 2
+| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw))
+    when not (approx_present v ls) -> 3
+| Llet (true , vv, lv, l) -> 4
+| _ -> 5
+;;
+
+test "lower_bind" (lower_bind 0 0) (Llet (true,0, Lvar 1, Lvar 2)) 4 ;
+test "lower_bind" (lower_bind 0 0) (Lvar 0) 5 ;
+test "lower_bind" (lower_bind 0 0) (Lifthenelse (Lvar 0, Lvar 1, Lvar 2)) 1
+;;
+
+
+type field_kind =
+    Fvar of field_kind option ref
+  | Fpresent
+  | Fabsent
+
+let unify_kind (k1, k2) =  match k1, k2 with
+    (Fvar r, (Fvar _ | Fpresent))             -> 1
+  | (Fpresent, Fvar r)                        -> 2
+  | (Fpresent, Fpresent)                      -> 3
+  | _                                         -> 4
+
+
+let r = ref (Some Fpresent)
+;;
+
+test "unify"  unify_kind (Fvar r, Fpresent) 1 ;
+test "unify"  unify_kind (Fvar r, Fvar r) 1 ;
+test "unify"  unify_kind (Fvar r, Fabsent) 4 ;
+test "unify"  unify_kind (Fpresent, Fvar r) 2 ;
+test "unify"  unify_kind (Fpresent, Fpresent) 3 ;
+test "unify"  unify_kind (Fabsent, Fpresent) 4 ; ()
+;;
+
+
+type youyou = A | B | C | D of youyou
+
+let foo (k1, k2) = match k1,k2 with
+| D _, (A|D _) -> 1
+| (A|B),D _ -> 2
+| C,_       -> 3
+| _, (A|B|C) -> 4
+;;
+
+test "foo2" foo (D A,A) 1 ;
+test "foo2" foo (D A,B) 4 ;
+test "foo2" foo (A,A) 4 ; ()
+;;
+
+type yaya = A | B
+;;
+
+let yaya = function
+| A,_,_ -> 1
+| _,A,_ -> 2
+| B,B,_ -> 3
+| A,_,(100|103) -> 5
+;;
+
+test "yaya" yaya (A,A,0) 1 ;
+test "yaya" yaya (B,A,0) 2 ;
+test "yaya" yaya (B,B,100) 3 ; ()
+;;
+
+(*
+let yoyo =  function
+| [],_,_ -> 1
+| _,[],_ -> 2
+| _::_,_::_,_ -> 3
+| [],_,(100|103|104) -> 5
+| [],_,(100|103) -> 6
+| [],_,(1000|1001|1002|20000) -> 7
+;;
+
+test "yoyo" yoyo ([],[],0) 1 ;
+test "yoyo" yoyo ([1],[],0) 2 ;
+test "yoyo" yoyo ([1],[1],100) 3 ; ()
+;;
+
+let youyou = function
+  | (100|103|104) -> 1
+  | (100|103|101) -> 2
+  | (1000|1001|1002|20000) -> 3
+  | _ -> -1
+;;
+
+test "youyou" youyou 100 1 ;
+test "youyou" youyou 101 2 ;
+test "youyou" youyou 1000 3
+;;
+*)
+type autre =
+  |  C | D | E of autre | F of autre * autre | H of autre | I | J | K of string
+
+let rec autre = function
+| C,_,_ -> 1
+| _,C,_ -> 2
+| D,D,_ -> 3
+| (D|F (_,_)|H _|K _),_,_ -> 4
+| (_, (D|I|E _|F (_, _)|H _|K _), _) -> 8
+| (J,J,((C|D) as x |E x|F (_,x))) | (J,_,((C|J) as x)) -> autre (x,x,x)
+| (J, J, (I|H _|K _)) -> 9
+| I,_,_ -> 6
+| E _,_,_ -> 7
+;;
+
+test "autre" autre (J,J,F (D,D)) 3 ;
+test "autre" autre (J,J,D) 3 ;
+test "autre" autre (J,J,I) 9 ;
+test "autre" autre (H I,I,I) 4 ;
+test "autre" autre (J,J,H I) 9 ; ()
+;;
+
+
+type youpi = YA | YB | YC
+and hola = X | Y | Z | T of hola | U of hola | V of hola
+
+let xyz = function
+| YA,_,_ -> 1
+| _,YA,_ -> 2
+| YB,YB,_ -> 3
+| ((YB|YC), (YB|YC), (X|Y|Z|V _|T _)) -> 6
+| _,_,(X|U _) -> 8
+| _,_,Y -> 5
+;;
+
+test "xyz" xyz (YC,YC,X) 6 ;
+test "xyz" xyz (YC,YB,U X) 8 ;
+test "xyz" xyz (YB,YC,X) 6 ; ()
+;;
+
+
+(* Ce test est pour le compilo lui-meme *)
+let eq (x,y) = x=y
+;;
+
+test "eq" eq ("coucou", "coucou") true ; ()
+;;
+
+(* Test des gardes, non trivial *)
+
+let is_none = function
+  | None -> true
+  | _ -> false
+
+let garde x = match x with
+| (Some _, _) when is_none (snd x) -> 1
+| (Some (pc, _), Some pc') when pc = pc' -> 2
+| _ -> 3
+;;
+
+test "garde" garde (Some (1,1),None) 1 ;
+test "garde" garde (Some (1,1),Some 1) 2 ;
+test "garde" garde (Some (2,1),Some 1) 3 ; ()
+;;
+
+let orstring = function
+  | ("A"|"B"|"C") -> 2
+  | "D" -> 3
+  | _ -> 4
+;;
+
+test "orstring" orstring "A" 2 ;
+test "orstring" orstring "B" 2 ;
+test "orstring" orstring "C" 2 ;
+test "orstring" orstring "D" 3 ;
+test "orstring" orstring "E" 4 ; ()
+;;
+
+type var_t = [`Variant of [ `Some of string | `None | `Foo] ]
+
+let crash (pat:var_t) =
+      match pat with
+      | `Variant (`Some tag) -> tag
+      | `Variant (`None) -> "none"
+      | _ -> "foo"
+
+;;
+
+test "crash" crash (`Variant `None) "none" ;
+test "crash" crash (`Variant (`Some "coucou")) "coucou" ;
+test "crash" crash (`Variant (`Foo)) "foo" ; ()
+;;
+
+let flatgarde c =
+let x,y = c in
+match x,y with
+| (1,2)|(2,3) when y=2 -> 1
+| (1,_)|(_,3) -> 2
+| _ -> 3
+;;
+
+test "flatgarde" flatgarde (1,2) 1 ;
+test "flatgarde" flatgarde (1,3) 2 ;
+test "flatgarde" flatgarde (2,3) 2 ;
+test "flatgarde" flatgarde (2,4) 3 ; ()
+;;
+
+
+(* Les bugs de jerome *)
+type f =
+  | ABSENT 
+  | FILE
+  | SYMLINK
+  | DIRECTORY
+
+type r =
+  | Unchanged
+  | Deleted
+  | Modified
+  | PropsChanged
+  | Created
+
+let replicaContent2shortString rc =
+    let (typ, status) = rc in
+    match typ, status with
+      _, Unchanged             -> "        "
+    | ABSENT, Deleted         -> "deleted "
+    | FILE, Created           -> "new file"
+    | FILE, Modified          -> "changed "
+    | FILE, PropsChanged      -> "props   "
+    | SYMLINK, Created        -> "new link"
+    | SYMLINK, Modified       -> "chgd lnk"
+    | DIRECTORY, Created      -> "new dir "
+    | DIRECTORY, Modified     -> "chgd dir"
+    | DIRECTORY, PropsChanged -> "props   "
+    (* Cases that can't happen... *)
+
+    | ABSENT, (Created | Modified | PropsChanged)
+    | SYMLINK, PropsChanged
+    | (FILE|SYMLINK|DIRECTORY), Deleted
+                                -> "assert false"
+;;
+
+
+test "jerome_constr" 
+   replicaContent2shortString (ABSENT, Unchanged) "        " ;
+test "jerome_constr" 
+   replicaContent2shortString (ABSENT, Deleted) "deleted " ;
+test "jerome_constr" 
+   replicaContent2shortString (FILE, Modified) "changed " ;
+test "jerome_constr" 
+   replicaContent2shortString (DIRECTORY, PropsChanged) "props   " ;
+test "jerome_constr" 
+   replicaContent2shortString (FILE, Deleted) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (SYMLINK, Deleted) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (SYMLINK, PropsChanged) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (DIRECTORY, Deleted) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (ABSENT, Created) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (ABSENT, Modified) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (ABSENT, PropsChanged) "assert false" ;
+;;
+
+
+let replicaContent2shortString rc =
+    let (typ, status) = rc in
+    match typ, status with
+      _, `Unchanged             -> "        "
+    | `ABSENT, `Deleted         -> "deleted "
+    | `FILE, `Created           -> "new file"
+    | `FILE, `Modified          -> "changed "
+    | `FILE, `PropsChanged      -> "props   "
+    | `SYMLINK, `Created        -> "new link"
+    | `SYMLINK, `Modified       -> "chgd lnk"
+    | `DIRECTORY, `Created      -> "new dir "
+    | `DIRECTORY, `Modified     -> "chgd dir"
+    | `DIRECTORY, `PropsChanged -> "props   "
+    (* Cases that can't happen... *)
+
+    | `ABSENT, (`Created | `Modified | `PropsChanged)
+    | `SYMLINK, `PropsChanged
+    | (`FILE|`SYMLINK|`DIRECTORY), `Deleted
+                                -> "assert false"
+;;
+
+
+test "jerome_constr" 
+   replicaContent2shortString (`ABSENT, `Unchanged) "        " ;
+test "jerome_constr" 
+   replicaContent2shortString (`ABSENT, `Deleted) "deleted " ;
+test "jerome_constr" 
+   replicaContent2shortString (`FILE, `Modified) "changed " ;
+test "jerome_constr" 
+   replicaContent2shortString (`DIRECTORY, `PropsChanged) "props   " ;
+test "jerome_constr" 
+   replicaContent2shortString (`FILE, `Deleted) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (`SYMLINK, `Deleted) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (`SYMLINK, `PropsChanged) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (`DIRECTORY, `Deleted) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (`ABSENT, `Created) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (`ABSENT, `Modified) "assert false" ;
+test "jerome_constr" 
+   replicaContent2shortString (`ABSENT, `PropsChanged) "assert false" ;
+;;
+
+(* bug 319 *)
+
+type ab = A of int | B of int
+type cd = C | D
+
+let ohl = function
+  | (A (p) | B (p)), C -> p
+  | (A (p) | B (p)), D -> p
+;;
+
+test "ohl" ohl (A 0,C) 0 ;
+test "ohl" ohl (B 0,D) 0 ; ()
+;;
+
+(* bug 324 *)
+type pottier =
+  | A
+  | B
+;;
+
+let pottier x =
+  match x with
+  | (( (A, 1) | (B, 2)),A) -> false
+  | _ -> true
+;;
+
+test "pottier" pottier ((B,2),A) false ;
+test "pottier" pottier ((B,2),B) true ;
+test "pottier" pottier ((A,2),A) true ; ()
+;;
+
+(* bug 325 in bytecode compiler *)
+let coquery q =  match q with
+| y,0,([modu;defs]| [defs;modu;_]) -> y+defs-modu
+| _ -> 0
+;;
+
+test "coquery" coquery (1,0,[1 ; 2 ; 3]) 0 ;
+test "coquery" coquery (1,0,[1 ; 2]) 2 ; ()
+;;
+
+(*
+  Two other variable in or-pat tests
+*)
+type vars = A of int | B of (int * int) | C
+;;
+
+
+let vars1 = function
+  | (A x | B (_,x)) -> x
+  | C -> 0
+;;
+
+test "vars1" vars1 (A 1) 1 ;
+test "vars1" vars1 (B (1,2)) 2 ; ()
+;;
+
+let vars2 = function
+  | ([x]|[1 ; x ]|[1 ; 2 ; x]) -> x
+  | _ -> 0
+;;
+
+test"vars2" vars2 [1] 1 ;
+test"vars2" vars2 [1;2] 2 ;
+test"vars2" vars2 [1;2;3] 3 ;
+test"vars2" vars2 [0 ; 0] 0 ; ()
+;;
+
+(* Bug 342 *)
+type eber = {x:int; y: int; z:bool}
+
+let eber = function
+  | {x=a; z=true}
+  | {y=a; z=false} -> a
+;;
+
+test "eber" eber {x=0 ; y=1 ; z=true} 0 ;
+test "eber" eber {x=1 ; y=0 ; z=false} 0 ; ()
+;;
+
+
+(* Enchainement des test d'intervalle *)
+
+let escaped = function
+  | '"' | '\\' | '\n' | '\t' -> 2
+  | c -> 1
+;;
+
+test "escaped" escaped '"' 2 ;
+test "escaped" escaped '\\' 2 ;
+test "escaped" escaped '\n' 2 ;
+test "escaped" escaped '\t' 2 ;
+test "escaped" escaped '\000' 1 ;
+test "escaped" escaped ' ' 1 ;
+test "escaped" escaped '\000' 1 ;
+test "escaped" escaped '[' 1 ;
+test "escaped" escaped ']' 1 ;
+test "escaped" escaped '!' 1 ;
+test "escaped" escaped '#' 1 ;
+()
+;;
+
+(* For compilation speed (due to J. Garigue) *)
+exception Unknown_Reply of int
+
+type command_reply =
+   RPL_TRYAGAIN
+ | RPL_TRACEEND
+ | RPL_TRACELOG
+ | RPL_ADMINEMAIL
+ | RPL_ADMINLOC2
+ | RPL_ADMINLOC1
+ | RPL_ADMINME
+ | RPL_LUSERME
+ | RPL_LUSERCHANNELS
+ | RPL_LUSERUNKNOWN
+ | RPL_LUSEROP
+ | RPL_LUSERCLIENT
+ | RPL_STATSDLINE
+ | RPL_STATSDEBUG
+ | RPL_STATSDEFINE
+ | RPL_STATSBLINE
+ | RPL_STATSPING
+ | RPL_STATSSLINE
+ | RPL_STATSHLINE
+ | RPL_STATSOLINE
+ | RPL_STATSUPTIME
+ | RPL_STATSLLINE
+ | RPL_STATSVLINE
+ | RPL_SERVLISTEND
+ | RPL_SERVLIST
+ | RPL_SERVICE
+ | RPL_ENDOFSERVICES
+ | RPL_SERVICEINFO
+ | RPL_UMODEIS
+ | RPL_ENDOFSTATS
+ | RPL_STATSYLINE
+ | RPL_STATSQLINE
+ | RPL_STATSKLINE
+ | RPL_STATSILINE
+ | RPL_STATSNLINE
+ | RPL_STATSCLINE
+ | RPL_STATSCOMMANDS
+ | RPL_STATSLINKINFO
+ | RPL_TRACERECONNECT
+ | RPL_TRACECLASS
+ | RPL_TRACENEWTYPE
+ | RPL_TRACESERVICE
+ | RPL_TRACESERVER
+ | RPL_TRACEUSER
+ | RPL_TRACEOPERATOR
+ | RPL_TRACEUNKNOWN
+ | RPL_TRACEHANDSHAKE
+ | RPL_TRACECONNECTING
+ | RPL_TRACELINK
+ | RPL_NOUSERS
+ | RPL_ENDOFUSERS
+ | RPL_USERS
+ | RPL_USERSSTART
+ | RPL_TIME
+ | RPL_NOTOPERANYMORE
+ | RPL_MYPORTIS
+ | RPL_YOURESERVICE
+ | RPL_REHASHING
+ | RPL_YOUREOPER
+ | RPL_ENDOFMOTD
+ | RPL_MOTDSTART
+ | RPL_ENDOFINFO
+ | RPL_INFOSTART
+ | RPL_MOTD
+ | RPL_INFO
+ | RPL_ENDOFBANLIST
+ | RPL_BANLIST
+ | RPL_ENDOFLINKS
+ | RPL_LINKS
+ | RPL_CLOSEEND
+ | RPL_CLOSING
+ | RPL_KILLDONE
+ | RPL_ENDOFNAMES
+ | RPL_NAMREPLY
+ | RPL_ENDOFWHO
+ | RPL_WHOREPLY
+ | RPL_VERSION
+ | RPL_SUMMONING
+ | RPL_INVITING
+ | RPL_TOPIC
+ | RPL_NOTOPIC
+ | RPL_CHANNELMODEIS
+ | RPL_LISTEND
+ | RPL_LIST
+ | RPL_LISTSTART
+ | RPL_WHOISCHANNELS
+ | RPL_ENDOFWHOIS
+ | RPL_WHOISIDLE
+ | RPL_WHOISCHANOP
+ | RPL_ENDOFWHOWAS
+ | RPL_WHOWASUSER
+ | RPL_WHOISOPERATOR
+ | RPL_WHOISSERVER
+ | RPL_WHOISUSER
+ | RPL_NOWAWAY
+ | RPL_UNAWAY
+ | RPL_TEXT
+ | RPL_ISON
+ | RPL_USERHOST
+ | RPL_AWAY
+ | RPL_NONE
+
+let get_command_reply n =
+match n with
+   263    ->     RPL_TRYAGAIN
+ | 319    ->     RPL_WHOISCHANNELS
+ | 318    ->     RPL_ENDOFWHOIS
+ | 317    ->     RPL_WHOISIDLE
+ | 316    ->     RPL_WHOISCHANOP
+ | 369    ->     RPL_ENDOFWHOWAS
+ | 314    ->     RPL_WHOWASUSER
+ | 313    ->     RPL_WHOISOPERATOR
+ | 312    ->     RPL_WHOISSERVER
+ | 311    ->     RPL_WHOISUSER
+ | 262    ->     RPL_TRACEEND
+ | 261    ->     RPL_TRACELOG
+ | 259    ->     RPL_ADMINEMAIL
+ | 258    ->     RPL_ADMINLOC2
+ | 257    ->     RPL_ADMINLOC1
+ | 256    ->     RPL_ADMINME
+ | 255    ->     RPL_LUSERME
+ | 254    ->     RPL_LUSERCHANNELS
+ | 253    ->     RPL_LUSERUNKNOWN
+ | 252    ->     RPL_LUSEROP
+ | 251    ->     RPL_LUSERCLIENT
+ | 250    ->     RPL_STATSDLINE
+ | 249    ->     RPL_STATSDEBUG
+ | 248    ->     RPL_STATSDEFINE
+ | 247    ->     RPL_STATSBLINE
+ | 246    ->     RPL_STATSPING
+ | 245    ->     RPL_STATSSLINE
+ | 244    ->     RPL_STATSHLINE
+ | 243    ->     RPL_STATSOLINE
+ | 242    ->     RPL_STATSUPTIME
+ | 241    ->     RPL_STATSLLINE
+ | 240    ->     RPL_STATSVLINE
+ | 235    ->     RPL_SERVLISTEND
+ | 234    ->     RPL_SERVLIST
+ | 233    ->     RPL_SERVICE
+ | 232    ->     RPL_ENDOFSERVICES
+ | 231    ->     RPL_SERVICEINFO
+ | 221    ->     RPL_UMODEIS
+ | 219    ->     RPL_ENDOFSTATS
+ | 218    ->     RPL_STATSYLINE
+ | 217    ->     RPL_STATSQLINE
+ | 216    ->     RPL_STATSKLINE
+ | 215    ->     RPL_STATSILINE
+ | 214    ->     RPL_STATSNLINE
+ | 213    ->     RPL_STATSCLINE
+ | 212    ->     RPL_STATSCOMMANDS
+ | 211    ->     RPL_STATSLINKINFO
+ | 210    ->     RPL_TRACERECONNECT
+ | 209    ->     RPL_TRACECLASS
+ | 208    ->     RPL_TRACENEWTYPE
+ | 207    ->     RPL_TRACESERVICE
+ | 206    ->     RPL_TRACESERVER
+ | 205    ->     RPL_TRACEUSER
+ | 204    ->     RPL_TRACEOPERATOR
+ | 203    ->     RPL_TRACEUNKNOWN
+ | 202    ->     RPL_TRACEHANDSHAKE
+ | 201    ->     RPL_TRACECONNECTING
+ | 200    ->     RPL_TRACELINK
+ | 395    ->     RPL_NOUSERS
+ | 394    ->     RPL_ENDOFUSERS
+ | 393    ->     RPL_USERS
+ | 392    ->     RPL_USERSSTART
+ | 391    ->     RPL_TIME
+ | 385    ->     RPL_NOTOPERANYMORE
+ | 384    ->     RPL_MYPORTIS
+ | 383    ->     RPL_YOURESERVICE
+ | 382    ->     RPL_REHASHING
+ | 381    ->     RPL_YOUREOPER
+ | 376    ->     RPL_ENDOFMOTD
+ | 375    ->     RPL_MOTDSTART
+ | 374    ->     RPL_ENDOFINFO
+ | 373    ->     RPL_INFOSTART
+ | 372    ->     RPL_MOTD
+ | 371    ->     RPL_INFO
+ | 368    ->     RPL_ENDOFBANLIST
+ | 367    ->     RPL_BANLIST
+ | 365    ->     RPL_ENDOFLINKS
+ | 364    ->     RPL_LINKS
+ | 363    ->     RPL_CLOSEEND
+ | 362    ->     RPL_CLOSING
+ | 361    ->     RPL_KILLDONE
+ | 366    ->     RPL_ENDOFNAMES
+ | 353    ->     RPL_NAMREPLY
+ | 315    ->     RPL_ENDOFWHO
+ | 352    ->     RPL_WHOREPLY
+ | 351    ->     RPL_VERSION
+ | 342    ->     RPL_SUMMONING
+ | 341    ->     RPL_INVITING
+ | 332    ->     RPL_TOPIC
+ | 331    ->     RPL_NOTOPIC
+ | 324    ->     RPL_CHANNELMODEIS
+ | 323    ->     RPL_LISTEND
+ | 322    ->     RPL_LIST
+ | 321    ->     RPL_LISTSTART
+ | 306    ->     RPL_NOWAWAY
+ | 305    ->     RPL_UNAWAY
+ | 304    ->     RPL_TEXT
+ | 303    ->     RPL_ISON
+ | 302    ->     RPL_USERHOST
+ | 301    ->     RPL_AWAY
+ | 300    ->     RPL_NONE
+ | _ -> raise (Unknown_Reply n)
+
+(* Bug 454 *)
+type  habert_a=
+  | A of habert_c
+  | B of habert_c
+  
+and habert_c= {lvar:int; lassoc: habert_c;lnb:int} 
+  
+  
+let habert=function
+  | (A {lnb=i}|B {lnb=i}) when i=0 -> 1
+  | A {lassoc=({lnb=j});lnb=i} -> 2
+  | _ -> 3
+;;
+
+let rec ex0 = {lvar=0 ; lnb=0 ; lassoc=ex1}
+and ex1 = {lvar=1 ; lnb=1 ; lassoc=ex0} in
+
+test "habert" habert (A ex0) 1 ;
+test "habert" habert (B ex0) 1 ;
+test "habert" habert (A ex1) 2 ;
+test "habert" habert (B ex1) 3 ;
+
+(* Problems with interval test in arithmetic mod 2^31, bug #359 *)
+(* From manuel Fahndrich *)
+
+type type_expr = [
+  | `TTuple of type_expr list
+  | `TConstr of type_expr list
+  | `TVar of string
+  | `TVariant of string list
+  | `TBlock of int
+  | `TCopy of type_expr
+  ] 
+
+and recurs_type_expr = [
+  | `TTuple of type_expr list
+  | `TConstr of type_expr list
+  | `TVariant of string list
+  ] 
+
+
+let rec maf te =
+    match te with
+    | `TCopy te -> 1
+    | `TVar _ -> 2
+    | `TBlock _ -> 2
+    | #recurs_type_expr as desc ->
+
+        let te =
+          (match desc with
+            `TTuple tl ->
+              4
+          | `TConstr tl ->
+              5
+          | `TVariant (row) ->
+              6
+                )
+        in
+
+        te
+;;
+
+let base = `TBlock 0
+;;
+
+test "maf" maf (`TCopy base) 1 ;
+test "maf" maf (`TVar "test") 2 ;
+test "maf" maf (`TBlock 0) 2 ;
+test "maf" maf (`TTuple []) 4 ;
+test "maf" maf (`TConstr []) 5 ;
+test "maf" maf (`TVariant []) 6
+;;
+
+(* PR#1310
+  Using ``get_args'' in place or an ad-hoc ``matcher'' function for tuples.
+  Has made the compiler [3.05] to fail.
+*)
+type t_seb = Uin | Uout
+;;
+
+let rec seb = function
+  | ((i, Uin) | (i, Uout)), Uout -> 1
+  | ((j, Uin) | (j, Uout)), Uin ->  2
+;;
+
+test "seb" seb ((0,Uin),Uout) 1 ;
+test "seb" seb ((0,Uout),Uin) 2 ;
+()
+;;
+
+(* Talk with Jacques
+     - type 'b is still open ??
+     - better case generation, accept intervals of size 1 when ok_inter is
+       false (in Switch)
+*)
+
+(*
+File "morematch.ml", line 1060, characters 8-65:
+Warning: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+A `D
+*)
+type ('a, 'b) t_j = A of 'a | B of 'b * 'a | C
+
+let f = function
+  | A (`A|`C) -> 0
+  | B (`B,`D) -> 1
+  | C -> 2
+
+let g x = try f x with Match_failure _ -> 3
+
+let _ =
+  test "jacques" g (A `A) 0 ;
+  test "jacques" g (A `C) 0 ;
+  test "jacques" g (B (`B,`D)) 1 ;
+  test "jacaues" g C 2 ;
+(*  test "jacques" g (B (`A,`D)) 3 ; (* type incorrect expected behavior ? *)*)
+  ()
+
+(*
+  Compilation bug, segfault, because of incorrect compilation
+  of unused match case .. -> "11"
+*)
+
+type t_l = A | B
+
+let f = function
+  |  _, _, _, _, _, _, _, _, _, _, _, _, _, B, _, _ -> "0"
+  |  _, _, _, B, A, _, _, _, _, _, _, _, _, _, _, _ -> "1"
+  |  _, _, _, B, _, A, _, _, A, _, _, _, _, _, _, _ -> "2"
+  |  _, _, _, _, _, _, _, _, _, _, B, A, _, A, _, _ -> "3"
+  |  _, _, _, _, _, _, _, B, _, _, _, _, B, _, A, A -> "4"
+  |  A, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "5"
+  |  _, _, _, _, _, _, _, B, _, B, _, _, _, _, _, _ -> "6"
+  |  _, B, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "7"
+  |  _, A, A, _, A, _, B, _, _, _, _, _, _, _, _, B -> "8"
+  |  _, _, _, _, B, _, _, _, _, _, _, _, _, _, B, _ -> "9"
+  |  _, _, _, _, _, _, _, _, _, _, _, B, _, _, _, _ -> "10"
+  |  _, _, _, _, _, A, _, _, _, _, B, _, _, _, _, _ -> "11"
+  |  B, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "12"
+  |  _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "13"
+
+(*
+File "morematch.ml", line 1094, characters 5-51:
+Warning: this match case is unused.
+File "morematch.ml", line 1096, characters 5-51:
+Warning: this match case is unused.
+*)
+let _  =
+  test "luc"  f (B, A, A, A, A, A, A, A, A, A, A, B, A, A, A, A) "10" ;
+  test "luc"  f (B, A, A, A, A, A, A, A, A, A, A, A, A, A, A, A) "12" ;
+ ()
+
+(*
+  By Gilles Peskine, compilation raised some assert false i make_failactionneg
+*)
+
+type bg = [
+  | `False
+  | `True
+  ]
+  
+type vg = [
+  | `A
+  | `B
+  | `U of int
+  | `V of int
+  ]
+
+type tg = {
+    v : vg;
+    x : bg;
+  }
+
+let predg x = true 
+
+let rec gilles o = match o with
+  | {v = (`U data | `V data); x = `False} when predg o -> 1
+  | {v = (`A|`B) ; x = `False}
+  | {v = (`U _ | `V _); x = `False}
+  | {v = _ ; x = `True}
+    -> 2
diff --git a/test/Moretest/multdef.ml b/test/Moretest/multdef.ml
new file mode 100644
index 00000000..ac5f488f
--- /dev/null
+++ b/test/Moretest/multdef.ml
@@ -0,0 +1,2 @@
+let f x = x + 1
+external g : string -> int = "int_of_string"
diff --git a/test/Moretest/multdef.mli b/test/Moretest/multdef.mli
new file mode 100644
index 00000000..8d67a548
--- /dev/null
+++ b/test/Moretest/multdef.mli
@@ -0,0 +1,3 @@
+val f : int -> int
+val f : int -> int
+val g : string -> int
diff --git a/test/Moretest/patmatch.ml b/test/Moretest/patmatch.ml
new file mode 100644
index 00000000..0077e775
--- /dev/null
+++ b/test/Moretest/patmatch.ml
@@ -0,0 +1,78 @@
+(* Tests for matchings on integers and characters *)
+
+(* Dense integer switch *)
+
+let f = function 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 -> 4 | 5 -> 5 | 6 -> 6 | _ -> 0
+
+(* Sparse integer switch *)
+
+let g = function 303 -> 1 | 401 -> 2 | _ -> 0
+
+(* Very sparse integer switch *)
+
+let iszero = function 0 -> true | _ -> false
+
+(* Simple matching on characters *)
+
+let h = function
+    'a' -> "a"
+  | 'e' -> "e"
+  | 'i' -> "i"
+  | 'o' -> "o"
+  | 'u' -> "u"
+  | _ -> "?"
+
+(* Matching with orpats *)
+
+let k = function
+    ' ' | '\t' | '\n' | '\r' -> "blk"
+  | 'A'..'Z' | 'a'..'z' | '\192'..'\255' -> "letr"
+  | '0'..'9' -> "dig"
+  | '!'|'%'|'&'|'$'|'#'|'+'|'/'|':'|'<'|'='|'>'|'?'|'@'|'\\'|
+             '~'|'^'|'|'|'*' -> "oper"
+  | _ -> "othr"
+
+(* Matching on arrays *)
+
+let p = function [| x |] -> x | _ -> assert false
+
+let q = function [| x |] -> x | _ -> 0
+
+let r = function [| x |] -> x | _ -> 0.0
+
+let l = function
+    [||] -> 0
+  | [|x|] -> x + 1
+  | [|x;y|] -> x + y
+  | [|x;y;z|] -> x + y + z
+
+(* The test *)
+
+open Printf
+
+let _ =
+  for i = -5 to 10 do printf "f(%d) = %d\n" i (f i) done;
+  List.iter (fun i -> printf "g(%d) = %d\n" i (g i))
+            [0;300;303;305;400;401;402;999];
+  for i = -2 to 2 do printf "iszero(%d) = %B\n" i (iszero i) done;
+  for i = 97 to 126 do
+    let c = Char.chr i in
+    printf "h(%c) = %s\n" c (h c)
+  done;
+  for i = 0 to 255 do
+    let c = Char.chr i in
+    printf "k(%s) = %s\t" (Char.escaped c) (k c)
+  done;
+  printf "\n";
+  printf "p([|\"hello\"|]) = %s\n" (p [|"hello"|]);
+  printf "p([|1.0|]) = %f\n" (p [|1.0|]);
+  printf "q([|2|]) = %d\n" (q [|2|]);
+  printf "r([|3.0|]) = %f\n" (r [|3.0|]);
+  printf "l([||]) = %d\n" (l [||]);
+  printf "l([|1|]) = %d\n" (l [|1|]);
+  printf "l([|2;3|]) = %d\n" (l [|2;3|]);
+  printf "l([|4;5;6|]) = %d\n" (l [|4;5;6|]);
+  exit 0
+
+
+
diff --git a/test/Moretest/recvalues.ml b/test/Moretest/recvalues.ml
new file mode 100644
index 00000000..c00ced82
--- /dev/null
+++ b/test/Moretest/recvalues.ml
@@ -0,0 +1,38 @@
+(* Recursive value definitions *)
+
+let _ =
+  let rec x = 1 :: x in
+  if match x with
+       1 :: x' -> x == x'
+     | _ -> false
+  then print_string "Test 1: passed\n"
+  else print_string "Test 1: FAILED\n";
+  let one = 1 in
+  let rec y = (one, one+1) :: y in  
+  if match y with
+       (1,2) :: y' -> y == y'
+     | _ -> false
+  then print_string "Test 2: passed\n"
+  else print_string "Test 2: FAILED\n";
+  let rec z = (Gc.minor(); (one, one+1)) :: z in
+  (* Trash the minor generation *)
+  for i = 0 to 50000 do ignore (ref 0) done;
+  if match z with
+       (1,2) :: z' -> z == z'
+     | _ -> false
+  then print_string "Test 3: passed\n"
+  else print_string "Test 3: FAILED\n";
+;;
+
+let rec s = "bar"
+and idx = 1
+and x1 = let f x = Printf.printf "%s\n" x in f "foo"; s, x4
+and x2 = [| x1; x1 |]
+and x3 = (fun () -> fst (x2.(idx))) :: x3
+and x4 = {contents = x3}
+;;
+
+Gc.minor ();;
+if (List.hd (!(snd (x2.(0))))) () == s
+then print_string "Test 4: passed\n"
+else print_string "Test 4: FAILED\n"
diff --git a/test/Moretest/regexp.ml b/test/Moretest/regexp.ml
new file mode 100644
index 00000000..a932b74c
--- /dev/null
+++ b/test/Moretest/regexp.ml
@@ -0,0 +1,975 @@
+open Printf
+
+let build_result ngroups input =
+  let res = Array.make (ngroups + 1) "~" in
+  for i = 0 to ngroups do
+    try
+      res.(i) <- Str.matched_group i input
+    with Not_found -> ()
+  done;
+  res
+
+let search_forward re ng input start =
+  try
+    ignore(Str.search_forward re input start);
+    build_result ng input
+  with Not_found ->
+    [||]
+
+let search_backward re ng input start =
+  try
+    ignore(Str.search_backward re input start);
+    build_result ng input
+  with Not_found ->
+    [||]
+
+let partial_match re ng input start =
+  if Str.string_partial_match re input start
+  then build_result ng input
+  else [||]
+
+let start_test msg =
+  print_newline(); printf "%s\n  " msg
+
+let num_failures = ref 0
+
+let test res1 res2 =
+  if res1 = res2 
+  then print_char '.'
+  else begin print_string " FAIL "; incr num_failures end
+
+let test_search_forward r ng s exp =
+  test (search_forward r ng s 0) exp
+
+let test_search_backward r ng s exp =
+  test (search_backward r ng s (String.length s)) exp
+
+let test_partial_match r ng s exp =
+  test (partial_match r ng s 0) exp
+
+let end_test () =
+  print_newline();
+  if !num_failures = 0 then
+    printf "All tests passed\n"
+  else begin
+    printf "TEST FAILED: %d failure(s)\n" !num_failures;
+    exit 2
+  end
+
+let automated_test() =
+
+  (** Forward searches *)
+  start_test "Search for /the quick brown fox/";
+  let r = Str.regexp "the quick brown fox" in
+  let n = 0 in
+  test_search_forward r n "the quick brown fox"
+    [|"the quick brown fox"|];
+  test_search_forward r n "What do you know about the quick brown fox?"
+    [|"the quick brown fox"|];
+  test_search_forward r n "The quick brown FOX"
+    [||];
+  test_search_forward r n "What do you know about THE QUICK BROWN FOX?"
+    [||];
+
+  start_test "Search for /the quick brown fox/";
+  let r = Str.regexp_case_fold "the quick brown fox" in
+  let n = 0 in
+  test_search_forward r n "the quick brown fox"
+    [|"the quick brown fox"|];
+  test_search_forward r n "What do you know about the quick brown fox?"
+    [|"the quick brown fox"|];
+  test_search_forward r n "The quick brown FOX"
+    [|"The quick brown FOX"|];
+  test_search_forward r n "What do you know about THE QUICK BROWN FOX?"
+    [|"THE QUICK BROWN FOX"|];
+  test_search_forward r n "The slow white snail"
+    [||];
+
+  start_test "Search for /a*abc?xyz+pqrrrabbb*xyyyyy?pq?q?q?q?q?q?AB*zz/";
+  let r = Str.regexp "a*abc?xyz+pqrrrabbb*xyyyyy?pq?q?q?q?q?q?AB*zz" in
+  let n = 0 in
+  test_search_forward r n "abxyzpqrrrabbxyyyypqAzz"
+    [|"abxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "abxyzpqrrrabbxyyyypqAzz"
+    [|"abxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aabxyzpqrrrabbxyyyypqAzz"
+    [|"aabxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aaabxyzpqrrrabbxyyyypqAzz"
+    [|"aaabxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aaaabxyzpqrrrabbxyyyypqAzz"
+    [|"aaaabxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "abcxyzpqrrrabbxyyyypqAzz"
+    [|"abcxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aabcxyzpqrrrabbxyyyypqAzz"
+    [|"aabcxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aaabcxyzpqrrrabbxyyyypAzz"
+    [|"aaabcxyzpqrrrabbxyyyypAzz"|];
+  test_search_forward r n "aaabcxyzpqrrrabbxyyyypqAzz"
+    [|"aaabcxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqAzz"
+    [|"aaabcxyzpqrrrabbxyyyypqqAzz"|];
+  test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqAzz"
+    [|"aaabcxyzpqrrrabbxyyyypqqqAzz"|];
+  test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqAzz"
+    [|"aaabcxyzpqrrrabbxyyyypqqqqAzz"|];
+  test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqqAzz"
+    [|"aaabcxyzpqrrrabbxyyyypqqqqqAzz"|];
+  test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqqqAzz"
+    [|"aaabcxyzpqrrrabbxyyyypqqqqqqAzz"|];
+  test_search_forward r n "aaaabcxyzpqrrrabbxyyyypqAzz"
+    [|"aaaabcxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "abxyzzpqrrrabbxyyyypqAzz"
+    [|"abxyzzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aabxyzzzpqrrrabbxyyyypqAzz"
+    [|"aabxyzzzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aaabxyzzzzpqrrrabbxyyyypqAzz"
+    [|"aaabxyzzzzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aaaabxyzzzzpqrrrabbxyyyypqAzz"
+    [|"aaaabxyzzzzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "abcxyzzpqrrrabbxyyyypqAzz"
+    [|"abcxyzzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aabcxyzzzpqrrrabbxyyyypqAzz"
+    [|"aabcxyzzzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aaabcxyzzzzpqrrrabbxyyyypqAzz"
+    [|"aaabcxyzzzzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aaaabcxyzzzzpqrrrabbxyyyypqAzz"
+    [|"aaaabcxyzzzzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyyypqAzz"
+    [|"aaaabcxyzzzzpqrrrabbbxyyyypqAzz"|];
+  test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyyyypqAzz"
+    [|"aaaabcxyzzzzpqrrrabbbxyyyyypqAzz"|];
+  test_search_forward r n "aaabcxyzpqrrrabbxyyyypABzz"
+    [|"aaabcxyzpqrrrabbxyyyypABzz"|];
+  test_search_forward r n "aaabcxyzpqrrrabbxyyyypABBzz"
+    [|"aaabcxyzpqrrrabbxyyyypABBzz"|];
+  test_search_forward r n ">>>aaabxyzpqrrrabbxyyyypqAzz"
+    [|"aaabxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n ">aaaabxyzpqrrrabbxyyyypqAzz"
+    [|"aaaabxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n ">>>>abcxyzpqrrrabbxyyyypqAzz"
+    [|"abcxyzpqrrrabbxyyyypqAzz"|];
+  test_search_forward r n "abxyzpqrrabbxyyyypqAzz"
+    [||];
+  test_search_forward r n "abxyzpqrrrrabbxyyyypqAzz"
+    [||];
+  test_search_forward r n "abxyzpqrrrabxyyyypqAzz"
+    [||];
+  test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyyyyypqAzz"
+    [||];
+  test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyypqAzz"
+    [||];
+  test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqqqqAzz"
+    [||];
+
+  start_test "Search for /^abc\\(abc\\)?zz/";
+  let r = Str.regexp "^abc\\(abc\\)?zz" in
+  let n = 1 in
+  test_search_forward r n "abczz"
+    [|"abczz"; "~"|];
+  test_search_forward r n "abcabczz"
+    [|"abcabczz"; "abc"|];
+  test_search_forward r n "zz"
+    [||];
+  test_search_forward r n "abcabcabczz"
+    [||];
+  test_search_forward r n ">>abczz"
+    [||];
+
+  start_test "Search for /^\\(b+\\|a\\)\\(b+\\|a\\)?c/";
+  let r = Str.regexp "^\\(b+\\|a\\)\\(b+\\|a\\)?c" in
+  let n = 2 in
+  test_search_forward r n "bc"
+    [|"bc"; "b"; "~"|];
+  test_search_forward r n "bbc"
+    [|"bbc"; "bb"; "~"|];
+  test_search_forward r n "bbbc"
+    [|"bbbc"; "bbb"; "~"|];
+  test_search_forward r n "bac"
+    [|"bac"; "b"; "a"|];
+  test_search_forward r n "bbac"
+    [|"bbac"; "bb"; "a"|];
+  test_search_forward r n "aac"
+    [|"aac"; "a"; "a"|];
+  test_search_forward r n "abbbbbbbbbbbc"
+    [|"abbbbbbbbbbbc"; "a"; "bbbbbbbbbbb"|];
+  test_search_forward r n "bbbbbbbbbbbac"
+    [|"bbbbbbbbbbbac"; "bbbbbbbbbbb"; "a"|];
+  test_search_forward r n "aaac"
+    [||];
+  test_search_forward r n "abbbbbbbbbbbac"
+    [||];
+
+  start_test "Search for /r\\(\\(g*\\|k\\)y?\\)*A/";
+  let r = Str.regexp "r\\(\\(g*\\|k\\)y?\\)*A" in
+  let n = 2 in
+  test_search_forward r n "ArA"
+    [|"rA"; "~"; "~"|];
+  test_search_forward r n "ArkA"
+    [|"rkA"; "k"; "k"|];
+  test_search_forward r n "AryA"
+    [|"ryA"; "y"; ""|];
+  test_search_forward r n "ArgggkyggkA"
+    [|"rgggkyggkA"; "k"; "k"|];
+
+  start_test "Search for /A\\(\\(t\\|v\\)\\(q?\\|n\\)\\)*A/";
+  let r = Str.regexp "A\\(\\(t\\|v\\)\\(q?\\|n\\)\\)*A" in
+  let n = 3 in
+  test_search_forward r n "AvA"
+    [|"AvA"; "v"; "v"; ""|];
+
+  start_test "Search for /A\\(\\(b\\(\\(d\\|l*\\)?\\|w\\)\\)*a\\)A/";
+  let r = Str.regexp "A\\(\\(b\\(\\(d\\|l*\\)?\\|w\\)\\)*a\\)A" in
+  let n = 4 in
+  test_search_forward r n "AbbaA"
+    [|"AbbaA"; "bba"; "b"; ""; ""|];
+
+  start_test "Search for /\\(\\|f\\)*x/";
+  let r = Str.regexp "\\(\\|f\\)*x" in
+  let n = 1 in
+  test_search_forward r n "abcd"
+    [||];
+  test_search_forward r n "fffff"
+    [||];
+  test_search_forward r n "fffxab"
+    [|"fffx"; "f"|];
+  test_search_forward r n "zzzxab"
+    [|"x"; "~"|];
+
+  start_test "Search for /\\(\\|f\\)+x/";
+  let r = Str.regexp "\\(\\|f\\)+x" in
+  let n = 1 in
+  test_search_forward r n "abcd"
+    [||];
+  test_search_forward r n "fffff"
+    [||];
+  test_search_forward r n "fffxab"
+    [|"fffx"; "f"|];
+  test_search_forward r n "zzzxab"
+    [|"x"; ""|];
+
+  start_test "Search for /A\\(.?\\)*A/";
+  let r = Str.regexp "A\\(.?\\)*A" in
+  let n = 1 in
+  test_search_forward r n "AA"
+    [|"AA"; "~"|];
+  test_search_forward r n "AAA"
+    [|"AAA"; "A"|];
+  test_search_forward r n "AbA"
+    [|"AbA"; "b"|];
+  test_search_forward r n "A"
+    [||];
+
+  start_test "Search for /\\([ab]*\\)\\1+c/";
+  let r = Str.regexp "\\([ab]*\\)\\1+c" in
+  let n = 1 in
+  test_search_forward r n "abababc"
+    [| "abababc"; "ab" |];
+  test_search_forward r n "abbc"
+    [| "bbc"; "b" |];
+  test_search_forward r n "abc"
+    [| "c"; "" |];
+
+  start_test "Search for /^\\(\\(b+\\|a\\)\\(b+\\|a\\)?\\)?bc/";
+  let r = Str.regexp "^\\(\\(b+\\|a\\)\\(b+\\|a\\)?\\)?bc" in
+  let n = 3 in
+  test_search_forward r n "bbc"
+    [|"bbc"; "b"; "b"; "~"|];
+
+  start_test "Search for /^\\(\\(b*\\|ba\\)\\(b*\\|ba\\)?\\)?bc/";
+  let r = Str.regexp "^\\(\\(b*\\|ba\\)\\(b*\\|ba\\)?\\)?bc" in
+  let n = 3 in
+  test_search_forward r n "babc"
+    [|"babc"; "ba"; ""; "ba"|];
+  test_search_forward r n "bbabc"
+    [|"bbabc"; "bba"; "b"; "ba"|];
+  test_search_forward r n "bababc"
+    [|"bababc"; "baba"; "ba"; "ba"|];
+  test_search_forward r n "bababbc"
+    [||];
+  test_search_forward r n "babababc"
+    [||];
+
+  start_test "Search for /^[]abcde]/";
+  let r = Str.regexp "^[]abcde]" in
+  let n = 0 in
+  test_search_forward r n "athing"
+    [|"a"|];
+  test_search_forward r n "bthing"
+    [|"b"|];
+  test_search_forward r n "]thing"
+    [|"]"|];
+  test_search_forward r n "cthing"
+    [|"c"|];
+  test_search_forward r n "dthing"
+    [|"d"|];
+  test_search_forward r n "ething"
+    [|"e"|];
+  test_search_forward r n "fthing"
+    [||];
+  test_search_forward r n "[thing"
+    [||];
+  test_search_forward r n "\\\\thing"
+    [||];
+
+  start_test "Search for /^[]cde]/";
+  let r = Str.regexp "^[]cde]" in
+  let n = 0 in
+  test_search_forward r n "]thing"
+    [|"]"|];
+  test_search_forward r n "cthing"
+    [|"c"|];
+  test_search_forward r n "dthing"
+    [|"d"|];
+  test_search_forward r n "ething"
+    [|"e"|];
+  test_search_forward r n "athing"
+    [||];
+  test_search_forward r n "fthing"
+    [||];
+
+  start_test "Search for /^[^]abcde]/";
+  let r = Str.regexp "^[^]abcde]" in
+  let n = 0 in
+  test_search_forward r n "fthing"
+    [|"f"|];
+  test_search_forward r n "[thing"
+    [|"["|];
+  test_search_forward r n "\\\\thing"
+    [|"\\"|];
+  test_search_forward r n "athing"
+    [||];
+  test_search_forward r n "bthing"
+    [||];
+  test_search_forward r n "]thing"
+    [||];
+  test_search_forward r n "cthing"
+    [||];
+  test_search_forward r n "dthing"
+    [||];
+  test_search_forward r n "ething"
+    [||];
+
+  start_test "Search for /^[^]cde]/";
+  let r = Str.regexp "^[^]cde]" in
+  let n = 0 in
+  test_search_forward r n "athing"
+    [|"a"|];
+  test_search_forward r n "fthing"
+    [|"f"|];
+  test_search_forward r n "]thing"
+    [||];
+  test_search_forward r n "cthing"
+    [||];
+  test_search_forward r n "dthing"
+    [||];
+  test_search_forward r n "ething"
+    [||];
+
+  start_test "Search for /^ÿ/";
+  let r = Str.regexp "^ÿ" in
+  let n = 0 in
+  test_search_forward r n "ÿ"
+    [|"ÿ"|];
+
+  start_test "Search for /^[0-9]+$/";
+  let r = Str.regexp "^[0-9]+$" in
+  let n = 0 in
+  test_search_forward r n "0"
+    [|"0"|];
+  test_search_forward r n "1"
+    [|"1"|];
+  test_search_forward r n "2"
+    [|"2"|];
+  test_search_forward r n "3"
+    [|"3"|];
+  test_search_forward r n "4"
+    [|"4"|];
+  test_search_forward r n "5"
+    [|"5"|];
+  test_search_forward r n "6"
+    [|"6"|];
+  test_search_forward r n "7"
+    [|"7"|];
+  test_search_forward r n "8"
+    [|"8"|];
+  test_search_forward r n "9"
+    [|"9"|];
+  test_search_forward r n "10"
+    [|"10"|];
+  test_search_forward r n "100"
+    [|"100"|];
+  test_search_forward r n "abc"
+    [||];
+
+  start_test "Search for /^.*nter/";
+  let r = Str.regexp "^.*nter" in
+  let n = 0 in
+  test_search_forward r n "enter"
+    [|"enter"|];
+  test_search_forward r n "inter"
+    [|"inter"|];
+  test_search_forward r n "uponter"
+    [|"uponter"|];
+
+  start_test "Search for /^xxx[0-9]+$/";
+  let r = Str.regexp "^xxx[0-9]+$" in
+  let n = 0 in
+  test_search_forward r n "xxx0"
+    [|"xxx0"|];
+  test_search_forward r n "xxx1234"
+    [|"xxx1234"|];
+  test_search_forward r n "xxx"
+    [||];
+
+  start_test "Search for /^.+[0-9][0-9][0-9]$/";
+  let r = Str.regexp "^.+[0-9][0-9][0-9]$" in
+  let n = 0 in
+  test_search_forward r n "x123"
+    [|"x123"|];
+  test_search_forward r n "xx123"
+    [|"xx123"|];
+  test_search_forward r n "123456"
+    [|"123456"|];
+  test_search_forward r n "123"
+    [||];
+  test_search_forward r n "x123x"
+    [||];
+
+  start_test "Search for /^\\([^!]+\\)!\\(.+\\)=apquxz\\.ixr\\.zzz\\.ac\\.uk$/";
+  let r = Str.regexp "^\\([^!]+\\)!\\(.+\\)=apquxz\\.ixr\\.zzz\\.ac\\.uk$" in
+  let n = 2 in
+  test_search_forward r n "abc!pqr=apquxz.ixr.zzz.ac.uk"
+    [|"abc!pqr=apquxz.ixr.zzz.ac.uk"; "abc"; "pqr"|];
+  test_search_forward r n "!pqr=apquxz.ixr.zzz.ac.uk"
+    [||];
+  test_search_forward r n "abc!=apquxz.ixr.zzz.ac.uk"
+    [||];
+  test_search_forward r n "abc!pqr=apquxz:ixr.zzz.ac.uk"
+    [||];
+  test_search_forward r n "abc!pqr=apquxz.ixr.zzz.ac.ukk"
+    [||];
+
+  start_test "Search for /\\([0-9a-f:]+\\)$/";
+  let r = Str.regexp_case_fold "\\([0-9a-f:]+\\)$" in
+  let n = 1 in
+  test_search_forward r n "0abc"
+    [|"0abc"; "0abc"|];
+  test_search_forward r n "abc"
+    [|"abc"; "abc"|];
+  test_search_forward r n "fed"
+    [|"fed"; "fed"|];
+  test_search_forward r n "E"
+    [|"E"; "E"|];
+  test_search_forward r n "::"
+    [|"::"; "::"|];
+  test_search_forward r n "5f03:12C0::932e"
+    [|"5f03:12C0::932e"; "5f03:12C0::932e"|];
+  test_search_forward r n "fed def"
+    [|"def"; "def"|];
+  test_search_forward r n "Any old stuff"
+    [|"ff"; "ff"|];
+  test_search_forward r n "0zzz"
+    [||];
+  test_search_forward r n "gzzz"
+    [||];
+  test_search_forward r n "fed "
+    [||];
+  test_search_forward r n "Any old rubbish"
+    [||];
+
+  start_test "Search for /^[a-z0-9][a-z0-9-]*\\(\\.[a-z0-9][A-Z0-9-]*\\)*\\.$/";
+  let r = Str.regexp_case_fold "^[a-z0-9][a-z0-9-]*\\(\\.[a-z0-9][A-Z0-9-]*\\)*\\.$" in
+  let n = 1 in
+  test_search_forward r n "a."
+    [|"a."; "~"|];
+  test_search_forward r n "Z."
+    [|"Z."; "~"|];
+  test_search_forward r n "2."
+    [|"2."; "~"|];
+  test_search_forward r n "ab-c."
+    [|"ab-c."; "~"|];
+  test_search_forward r n "ab-c.pq-r."
+    [|"ab-c.pq-r."; ".pq-r"|];
+  test_search_forward r n "sxk.zzz.ac.uk."
+    [|"sxk.zzz.ac.uk."; ".uk"|];
+  test_search_forward r n "sxk.ZZZ.ac.UK."
+    [|"sxk.ZZZ.ac.UK."; ".UK"|];
+  test_search_forward r n "x-.y-."
+    [|"x-.y-."; ".y-"|];
+  test_search_forward r n "-abc.peq."
+    [||];
+
+  start_test "Search for /^\\*\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\(\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\)*$/";
+  let r = Str.regexp "^\\*\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\(\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\)*$" in
+  let n = 3 in
+  test_search_forward r n "*.a"
+    [|"*.a"; "~"; "~"; "~"|];
+  test_search_forward r n "*.b0-a"
+    [|"*.b0-a"; "0-a"; "~"; "~"|];
+  test_search_forward r n "*.c3-b.c"
+    [|"*.c3-b.c"; "3-b"; ".c"; "~"|];
+  test_search_forward r n "*.c-a.b-c"
+    [|"*.c-a.b-c"; "-a"; ".b-c"; "-c"|];
+  test_search_forward r n "*.0"
+    [||];
+  test_search_forward r n "*.a-"
+    [||];
+  test_search_forward r n "*.a-b.c-"
+    [||];
+  test_search_forward r n "*.c-a.0-c"
+    [||];
+
+  start_test "Search for /^[0-9a-fA-F]\\(\\.[0-9a-fA-F]\\)*$/";
+  let r = Str.regexp "^[0-9a-fA-F]\\(\\.[0-9a-fA-F]\\)*$" in
+  let n = 1 in
+  test_search_forward r n "a.b.c.d"
+    [|"a.b.c.d"; ".d"|];
+  test_search_forward r n "A.B.C.D"
+    [|"A.B.C.D"; ".D"|];
+  test_search_forward r n "a.b.c.1.2.3.C"
+    [|"a.b.c.1.2.3.C"; ".C"|];
+  test_search_forward r n "a.b.c.dz"
+    [||];
+  test_search_forward r n "za"
+    [||];
+
+  start_test "Search for /^\\\".*\\\" *\\(;.*\\)?$/";
+  let r = Str.regexp "^\\\".*\\\" *\\(;.*\\)?$" in
+  let n = 1 in
+  test_search_forward r n "\"1234\""
+    [|"\"1234\""; "~"|];
+  test_search_forward r n "\"abcd\" ;"
+    [|"\"abcd\" ;"; ";"|];
+  test_search_forward r n "\"\" ; rhubarb"
+    [|"\"\" ; rhubarb"; "; rhubarb"|];
+  test_search_forward r n "\"1234\" : things"
+    [||];
+
+  start_test "Search for /^\\(a\\(b\\(c\\)\\)\\)\\(d\\(e\\(f\\)\\)\\)\\(h\\(i\\(j\\)\\)\\)$/";
+  let r = Str.regexp "^\\(a\\(b\\(c\\)\\)\\)\\(d\\(e\\(f\\)\\)\\)\\(h\\(i\\(j\\)\\)\\)$" in
+  let n = 9 in
+  test_search_forward r n "abcdefhij"
+    [|"abcdefhij"; "abc"; "bc"; "c"; "def"; "ef"; "f"; "hij"; "ij"; "j"|];
+
+  start_test "Search for /^[.^$|()*+?{,}]+/";
+  let r = Str.regexp "^[.^$|()*+?{,}]+" in
+  let n = 0 in
+  test_search_forward r n ".^$*(+)|{?,?}"
+    [|".^$*(+)|{?,?}"|];
+
+  start_test "Search for /\\(cat\\(a\\(ract\\|tonic\\)\\|erpillar\\)\\) \\1\\(\\)2\\(3\\)/";
+  let r = Str.regexp "\\(cat\\(a\\(ract\\|tonic\\)\\|erpillar\\)\\) \\1\\(\\)2\\(3\\)" in
+  let n = 5 in
+  test_search_forward r n "cataract cataract23"
+    [|"cataract cataract23"; "cataract"; "aract"; "ract"; ""; "3"|];
+  test_search_forward r n "catatonic catatonic23"
+    [|"catatonic catatonic23"; "catatonic"; "atonic"; "tonic"; ""; "3"|];
+  test_search_forward r n "caterpillar caterpillar23"
+    [|"caterpillar caterpillar23"; "caterpillar"; "erpillar"; "~"; ""; "3"|];
+
+  start_test "Search for /^From +\\([^ ]+\\) +[a-zA-Z][a-zA-Z][a-zA-Z] +[a-zA-Z][a-zA-Z][a-zA-Z] +[0-9]?[0-9] +[0-9][0-9]:[0-9][0-9]/";
+  let r = Str.regexp "^From +\\([^ ]+\\) +[a-zA-Z][a-zA-Z][a-zA-Z] +[a-zA-Z][a-zA-Z][a-zA-Z] +[0-9]?[0-9] +[0-9][0-9]:[0-9][0-9]" in
+  let n = 1 in
+  test_search_forward r n "From abcd  Mon Sep 01 12:33:02 1997"
+    [|"From abcd  Mon Sep 01 12:33"; "abcd"|];
+
+  start_test "Search for /\\ba/";
+  let r = Str.regexp "\\ba" in
+  let n = 0 in
+  test_search_forward r n "abcd"
+    [|"a"|];
+  test_search_forward r n "the a"
+    [|"a"|];
+  test_search_forward r n ".ab"
+    [|"a"|];
+  test_search_forward r n "bad"
+    [||];
+  test_search_forward r n "the ba"
+    [||];
+  test_search_forward r n "ba."
+    [||];
+
+  start_test "Search for /a\\b/";
+  let r = Str.regexp "a\\b" in
+  let n = 0 in
+  test_search_forward r n "a"
+    [|"a"|];
+  test_search_forward r n "bcda"
+    [|"a"|];
+  test_search_forward r n "a foo"
+    [|"a"|];
+  test_search_forward r n "a."
+    [|"a"|];
+  test_search_forward r n "bad"
+    [||];
+  test_search_forward r n "ab"
+    [||];
+
+  start_test "Search for /\\([a-z]*\\)b/";
+  let r = Str.regexp "\\([a-z]*\\)b" in
+  let n = 1 in
+  test_search_forward r n "abbb"
+    [|"abbb"; "abb"|];
+
+  start_test "Search for /\\([a-z]+\\)b/";
+  let r = Str.regexp "\\([a-z]+\\)b" in
+  let n = 1 in
+  test_search_forward r n "abbb"
+    [|"abbb"; "abb"|];
+
+  start_test "Search for /\\([a-z]?\\)b/";
+  let r = Str.regexp "\\([a-z]?\\)b" in
+  let n = 1 in
+  test_search_forward r n "bbbb"
+    [|"bb"; "b"|];
+
+  start_test "Search for /^a/";
+  let r = Str.regexp "^a" in
+  let n = 0 in
+  test_search_forward r n "abcdef"
+    [|"a"|];
+  test_search_forward r n "zzzz\nabcdef"
+    [|"a"|];
+
+  start_test "Search for /a$/";
+  let r = Str.regexp "a$" in
+  let n = 0 in
+  test_search_forward r n "xyza"
+    [|"a"|];
+  test_search_forward r n "xyza\nbcdef"
+    [|"a"|];
+
+  start_test "Null characters in regexps";
+  let r = Str.regexp "ab\000cd" in
+  let n = 0 in
+  test_search_forward r n "qerpoiuab\000cdwerltkh"
+    [| "ab\000cd" |];
+  let r = Str.regexp "\000cd" in
+  let n = 0 in
+  test_search_forward r n "qerpoiuab\000cdwerltkh"
+    [| "\000cd" |];
+
+  (** Backward searches *)
+  start_test "Backward search for /the quick/";
+  let r = Str.regexp "the quick" in
+  let n = 0 in
+  test_search_backward r n "the quick brown fox"
+    [|"the quick"|];
+  test_search_backward r n "What do you know about the quick brown fox?"
+    [|"the quick"|];
+  test_search_backward r n "The quick brown FOX"
+    [||];
+  test_search_backward r n "What do you know about THE QUICK BROWN FOX?"
+    [||];
+
+  start_test "Backward search for /a\\([0-9]+\\)/";
+  let r = Str.regexp "a\\([0-9]+\\)" in
+  let n = 1 in
+  test_search_backward r n "a123 a456zzzz"
+    [|"a456"; "456"|];
+  test_search_backward r n "ab123"
+    [||];
+
+  (** Partial match searches *)
+
+  start_test "Partial match for /partial match/";
+  let r = Str.regexp "partial match" in
+  let n = 0 in
+  test_partial_match r n ""
+    [|""|];
+  test_partial_match r n "partial matching"
+    [|"partial match"|];
+  test_partial_match r n "partial m"
+    [|"partial m"|];
+
+  start_test "Partial match for /\\(partial\\)\\|\\(match\\)/";
+  let r = Str.regexp "\\(partial\\)\\|\\(match\\)" in
+  let n = 2 in
+  test_partial_match r n ""
+    [|""; "~"; "~"|];
+  test_partial_match r n "part"
+    [|"part"; "~"; "~"|];
+  test_partial_match r n "partial"
+    [|"partial"; "partial"; "~"|];
+  test_partial_match r n "matching"
+    [|"match"; "~"; "match"|];
+  test_partial_match r n "mat"
+    [|"mat"; "~"; "~"|];
+  test_partial_match r n "zorglub"
+    [||];
+
+  (** Replacement *)
+  start_test "Global replacement";
+  test (Str.global_replace (Str.regexp "[aeiou]") ".."
+          "abcdefghijklmnopqrstuvwxyz")
+       "..bcd..fgh..jklmn..pqrst..vwxyz";
+  test (Str.global_replace (Str.regexp "[0-9]\\([0-9]*\\)") "-\\0-\\1-"
+          "abc012def3ghi45")
+       "abc-012-12-def-3--ghi-45-5-";
+  test (Str.global_replace (Str.regexp "[0-9]?") "."
+          "abc012def3ghi45")
+       ".a.b.c....d.e.f..g.h.i...";
+
+  start_test "First replacement";
+  test (Str.replace_first (Str.regexp "[eiou]") ".."
+          "abcdefghijklmnopqrstuvwxyz")
+       "abcd..fghijklmnopqrstuvwxyz";
+  test (Str.replace_first (Str.regexp "[0-9]\\([0-9]*\\)") "-\\0-\\1-"
+          "abc012def3ghi45")
+       "abc-012-12-def3ghi45";
+
+  (** XML tokenization *)
+  (* See "REX: XML Shallow Parsing with Regular Expressions",
+     Robert D. Cameron, Simon Fraser University, CMPT TR 1998-17. *)
+  start_test "XML tokenization";
+  begin 
+    let _TextSE = "[^<]+" in
+    let _UntilHyphen = "[^-]*-" in
+    let _Until2Hyphens = _UntilHyphen ^ "\\([^-]" ^ _UntilHyphen ^ "\\)*-" in
+    let _CommentCE = _Until2Hyphens ^ ">?" in
+    let _UntilRSBs = "[^]]*]\\([^]]+]\\)*]+" in
+    let _CDATA_CE = _UntilRSBs ^ "\\([^]>]" ^ _UntilRSBs ^ "\\)*>" in
+    let _S = "[ \n\t\r]+" in
+    let _NameStrt = "[A-Za-z_:]\\|[^\x00-\x7F]" in
+    let _NameChar = "[A-Za-z0-9_:.-]\\|[^\x00-\x7F]" in
+    let _Name = "\\(" ^ _NameStrt ^ "\\)\\(" ^ _NameChar ^ "\\)*" in
+    let _QuoteSE = "\"[^\"]*\"\\|'[^']*'" in
+    let _DT_IdentSE = _S ^ _Name ^ "\\(" ^ _S ^ "\\(" ^ _Name ^ "\\|" ^ _QuoteSE ^ "\\)\\)*" in
+    let _MarkupDeclCE = "\\([^]\"'><]\\|" ^ _QuoteSE ^ "\\)*>" in
+    let _S1 = "[\n\r\t ]" in
+    let _UntilQMs = "[^?]*\\?+" in
+    let _PI_Tail = "\\?>\\|" ^ _S1 ^ _UntilQMs ^ "\\([^>?]" ^ _UntilQMs ^ "\\)*>" in
+    let _DT_ItemSE = "<\\(!\\(--" ^ _Until2Hyphens ^ ">\\|[^-]" ^ _MarkupDeclCE ^ "\\)\\|\\?" ^ _Name ^ "\\(" ^ _PI_Tail ^ "\\)\\)\\|%" ^ _Name ^ ";\\|" ^ _S1 in
+    let _DocTypeCE = _DT_IdentSE ^ "\\(" ^ _S ^ "\\)?\\(\\[\\(" ^ _DT_ItemSE ^ "\\)*]\\(" ^ _S ^ "\\)?\\)?>?" in
+    let _DeclCE = "--\\(" ^ _CommentCE ^ "\\)?\\|\\[_CDATA\\[\\(" ^ _CDATA_CE ^ "\\)?\\|_DOCTYPE\\(" ^ _DocTypeCE ^ "\\)?" in
+    let _PI_CE = _Name ^ "\\(" ^ _PI_Tail ^ "\\)?" in
+    let _EndTagCE = _Name ^ "\\(" ^ _S ^ "\\)?>?" in
+    let _AttValSE = "\"[^<\"]*\"\\|'[^<']*'" in
+    let _ElemTagCE = _Name ^ "\\(" ^ _S ^ _Name ^ "\\(" ^ _S ^ "\\)?=\\(" ^ _S ^ "\\)?\\(" ^ _AttValSE ^ "\\)\\)*\\(" ^ _S ^ "\\)?/?>?" in
+    let _MarkupSPE = "<\\(!\\(" ^ _DeclCE ^ "\\)?\\|\\?\\(" ^ _PI_CE ^ "\\)?\\|/\\(" ^ _EndTagCE ^ "\\)?\\|\\(" ^ _ElemTagCE ^ "\\)?\\)" in
+    let _XML_SPE = _TextSE ^ "\\|" ^ _MarkupSPE in
+    let input = "\
+<?xml version=\"1.0\"?>
+<?xml-stylesheet type=\"text/css\" href=\"nutrition.css\"?>
+<!DOCTYPE root [
+   <!ELEMENT root (stem)>
+   <!ELEMENT stem EMPTY>
+]>
+<!ELEMENT name (#PCDATA)>
+<![CDATA[my
+escaped text]]> 
+<nutrition>
+<daily-values>
+	<total-fat units=\"g\">65</total-fat>
+	<saturated-fat units=\"g\">20</saturated-fat>
+	<cholesterol units=\"mg\">300</cholesterol>
+	<sodium units=\"mg\">2400</sodium>
+	<carb units=\"g\">300</carb>
+	<fiber units=\"g\">25</fiber>
+	<protein units=\"g\">50</protein>
+</daily-values>
+<food>
+	<name>Avocado Dip</name>
+	<mfr>Sunnydale</mfr>
+	<serving units=\"g\">29</serving>
+	<calories total=\"110\" fat=\"100\"/>
+	<total-fat>11</total-fat>
+	<saturated-fat>3</saturated-fat>
+	<cholesterol>5</cholesterol>
+	<sodium>210</sodium>
+	<carb>2</carb>
+	<fiber>0</fiber>
+	<protein>1</protein>
+	<vitamins>
+		<a>0</a>
+		<c>0</c>
+	</vitamins>
+	<minerals>
+		<ca>0</ca>
+		<fe>0</fe>
+	</minerals>
+</food>
+<!--
+<food>
+	<name></name>
+	<mfr></mfr>
+	<serving units=\"g\"></serving>
+	<calories total=\"\" fat=\"\"/>
+	<total-fat></total-fat>
+	<saturated-fat></saturated-fat>
+	<cholesterol></cholesterol>
+	<sodium></sodium>
+	<carb></carb>
+	<fiber></fiber>
+	<protein></protein>
+	<vitamins>
+		<a></a>
+		<c></c>
+	</vitamins>
+	<minerals>
+		<ca></ca>
+		<fe></fe>
+	</minerals>
+</food>
+-->
+" in
+    let result = [
+  "<?xml version=\"1.0\"?>";
+  "\n";
+  "<?xml-stylesheet type=\"text/css\" href=\"nutrition.css\"?>";
+  "\n";
+  "<!";
+  "DOCTYPE root [\n   ";
+  "<!";
+  "ELEMENT root (stem)>\n   ";
+  "<!";
+  "ELEMENT stem EMPTY>\n]>\n";
+  "<!";
+  "ELEMENT name (#PCDATA)>\n";
+  "<!";
+  "[CDATA[my\nescaped text]]> \n";
+  "<nutrition>";
+  "\n";
+  "<daily-values>";
+  "\n\t";
+  "<total-fat units=\"g\">";
+  "65";
+  "</total-fat>";
+  "\n\t";
+  "<saturated-fat units=\"g\">";
+  "20";
+  "</saturated-fat>";
+  "\n\t";
+  "<cholesterol units=\"mg\">";
+  "300";
+  "</cholesterol>";
+  "\n\t";
+  "<sodium units=\"mg\">";
+  "2400";
+  "</sodium>";
+  "\n\t";
+  "<carb units=\"g\">";
+  "300";
+  "</carb>";
+  "\n\t";
+  "<fiber units=\"g\">";
+  "25";
+  "</fiber>";
+  "\n\t";
+  "<protein units=\"g\">";
+  "50";
+  "</protein>";
+  "\n";
+  "</daily-values>";
+  "\n";
+  "<food>";
+  "\n\t";
+  "<name>";
+  "Avocado Dip";
+  "</name>";
+  "\n\t";
+  "<mfr>";
+  "Sunnydale";
+  "</mfr>";
+  "\n\t";
+  "<serving units=\"g\">";
+  "29";
+  "</serving>";
+  "\n\t";
+  "<calories total=\"110\" fat=\"100\"/>";
+  "\n\t";
+  "<total-fat>";
+  "11";
+  "</total-fat>";
+  "\n\t";
+  "<saturated-fat>";
+  "3";
+  "</saturated-fat>";
+  "\n\t";
+  "<cholesterol>";
+  "5";
+  "</cholesterol>";
+  "\n\t";
+  "<sodium>";
+  "210";
+  "</sodium>";
+  "\n\t";
+  "<carb>";
+  "2";
+  "</carb>";
+  "\n\t";
+  "<fiber>";
+  "0";
+  "</fiber>";
+  "\n\t";
+  "<protein>";
+  "1";
+  "</protein>";
+  "\n\t";
+  "<vitamins>";
+  "\n\t\t";
+  "<a>";
+  "0";
+  "</a>";
+  "\n\t\t";
+  "<c>";
+  "0";
+  "</c>";
+  "\n\t";
+  "</vitamins>";
+  "\n\t";
+  "<minerals>";
+  "\n\t\t";
+  "<ca>";
+  "0";
+  "</ca>";
+  "\n\t\t";
+  "<fe>";
+  "0";
+  "</fe>";
+  "\n\t";
+  "</minerals>";
+  "\n";
+  "</food>";
+  "\n";
+  "<!--\n<food>\n\t<name></name>\n\t<mfr></mfr>\n\t<serving units=\"g\"></serving>\n\t<calories total=\"\" fat=\"\"/>\n\t<total-fat></total-fat>\n\t<saturated-fat></saturated-fat>\n\t<cholesterol></cholesterol>\n\t<sodium></sodium>\n\t<carb></carb>\n\t<fiber></fiber>\n\t<protein></protein>\n\t<vitamins>\n\t\t<a></a>\n\t\t<c></c>\n\t</vitamins>\n\t<minerals>\n\t\t<ca></ca>\n\t\t<fe></fe>\n\t</minerals>\n</food>\n-->";
+  "\n"] in
+    let re = Str.regexp _XML_SPE in
+    let rec process i l =
+      let j = try Str.search_forward re input i with Not_found -> (-1) in
+      if j < 0 then begin
+        test l []
+      end else begin
+        match l with
+          [] -> test 0 1 (* failure *)
+        | hd :: tl ->
+            test (Str.matched_string input) hd; process (Str.match_end()) tl
+      end in
+    process 0 result
+  end;
+
+  end_test()
+
+let manual_test regexp text =
+  try
+    ignore (Str.search_forward (Str.regexp regexp) text 0);
+    printf "Matched,";
+    begin try
+      for i = 0 to 31 do
+        try
+          let s = Str.matched_group i text in
+          printf " \\%d=%s" i s
+        with Not_found ->
+          ()
+      done
+    with Invalid_argument "Str.matched_group" -> (*yuck*)
+      ()
+    end;
+    print_newline()
+  with Not_found ->
+    printf "Not matched\n"
+
+let _ =
+  if Array.length Sys.argv >= 3
+  then manual_test Sys.argv.(1) Sys.argv.(2)
+  else automated_test()
diff --git a/test/Moretest/sets.ml b/test/Moretest/sets.ml
new file mode 100644
index 00000000..7ec77c4f
--- /dev/null
+++ b/test/Moretest/sets.ml
@@ -0,0 +1,39 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: sets.ml,v 1.4 2002/10/16 09:06:39 weis Exp $ *)
+
+module IntSet = Set.Make(struct type t = int let compare x y = x-y end)
+
+let even = List.fold_right IntSet.add [0; -2; 2; 4; 6; -10] IntSet.empty
+
+let odd = List.fold_right IntSet.add [9; -7; 5; 1; -3] IntSet.empty
+
+let _ =
+  for i = -10 to 10 do
+    Printf.printf "%d  %B  %B\n" i (IntSet.mem i even) (IntSet.mem i odd)
+  done
+
+module PowerSet(BaseSet: Set.S)
+               (SetOrd: functor(S: Set.S) -> Set.OrderedType) =
+  Set.Make(SetOrd(BaseSet))
+
+module IntSetSet = PowerSet(IntSet)(functor (S: Set.S) -> S)
+
+let setofset = List.fold_right IntSetSet.add [even; odd] IntSetSet.empty
+
+let _ =
+  List.iter
+    (fun s -> Printf.printf "%B\n" (IntSetSet.mem s setofset))
+    [IntSet.empty; even; odd; IntSet.union even odd]
+
+let _ = exit 0
diff --git a/test/Moretest/signals.ml b/test/Moretest/signals.ml
new file mode 100644
index 00000000..5451d8e5
--- /dev/null
+++ b/test/Moretest/signals.ml
@@ -0,0 +1,32 @@
+let rec tak (x, y, z as tuple) =
+  if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
+           else z
+
+let break_handler _ =
+  print_string "Thank you for pressing ctrl-C."; print_newline();
+  print_string "Allocating a bit..."; flush stdout;
+  tak(18,12,6); print_string "done."; print_newline()
+
+let stop_handler _ =
+  print_string "Thank you for pressing ctrl-Z."; print_newline();
+  print_string "Now raising an exception..."; print_newline();
+  raise Exit
+
+let _ =
+  Sys.signal Sys.sigint (Sys.Signal_handle break_handler);
+  Sys.signal Sys.sigtstp (Sys.Signal_handle stop_handler);
+  begin try
+    print_string "Computing like crazy..."; print_newline();
+    for i = 1 to 100 do tak(18,12,6) done;
+    print_string "Reading on input..."; print_newline();
+    for i = 1 to 5 do
+      try
+        let s = read_line () in
+        print_string ">> "; print_string s; print_newline()
+      with Exit ->
+        print_string "Got Exit, continuing."; print_newline()
+    done
+  with Exit ->
+    print_string "Got Exit, exiting."; print_newline()
+  end;
+  exit 0
diff --git a/test/Moretest/stackoverflow.ml b/test/Moretest/stackoverflow.ml
new file mode 100644
index 00000000..4d211bc8
--- /dev/null
+++ b/test/Moretest/stackoverflow.ml
@@ -0,0 +1,15 @@
+let rec f x =
+  if x land 0xFFFF <> 0
+  then 1 + f (x + 1)
+  else
+    try
+      1 + f (x + 1)
+    with Stack_overflow ->
+      print_string "x = "; print_int x; print_newline();
+      raise Stack_overflow
+
+let _ =
+  try
+    ignore(f 0)
+  with Stack_overflow ->
+    print_string "Stack overflow caught"; print_newline()
diff --git a/test/Moretest/syserror.ml b/test/Moretest/syserror.ml
new file mode 100644
index 00000000..46f62ead
--- /dev/null
+++ b/test/Moretest/syserror.ml
@@ -0,0 +1 @@
+let channel = open_out "titi:/toto"
diff --git a/test/Moretest/tailcalls.ml b/test/Moretest/tailcalls.ml
new file mode 100644
index 00000000..23b73535
--- /dev/null
+++ b/test/Moretest/tailcalls.ml
@@ -0,0 +1,28 @@
+let rec tailcall4 a b c d =
+  if a < 0
+  then b
+  else tailcall4 (a-1) (b+1) (c+2) (d+3)
+
+let rec tailcall8 a b c d e f g h =
+  if a < 0
+  then b
+  else tailcall8 (a-1) (b+1) (c+2) (d+3) (e+4) (f+5) (g+6) (h+7)
+
+let rec tailcall16 a b c d e f g h i j k l m n o p =
+  if a < 0
+  then b
+  else tailcall16 (a-1) (b+1) (c+2) (d+3) (e+4) (f+5) (g+6) (h+7)
+                  (i+8) (j+9) (k+10) (l+11) (m+12) (n+13) (o+14) (p+15)
+
+let indtailcall8 fn a b c d e f g h =
+  fn a b c d e f g h
+
+let indtailcall16 fn a b c d e f g h i j k l m n o p =
+  fn a b c d e f g h i j k l m n o p 
+
+let _ =
+  print_int (tailcall4 10000000 0 0 0); print_newline();
+  print_int (tailcall8 10000000 0 0 0 0 0 0 0); print_newline();
+  print_int (tailcall16 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline();
+  print_int (indtailcall8 tailcall8 10 0 0 0 0 0 0 0); print_newline();
+  print_int (indtailcall16 tailcall16 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline()
diff --git a/test/Moretest/testrandom.ml b/test/Moretest/testrandom.ml
new file mode 100644
index 00000000..150d4088
--- /dev/null
+++ b/test/Moretest/testrandom.ml
@@ -0,0 +1,13 @@
+open Random
+
+let _ = 
+  for i = 0 to 20 do
+    print_float (float 1000.); print_char ' '
+  done;
+  print_newline ();  print_newline ();
+  for i = 0 to 20 do
+    print_int (int 1000); print_char ' '
+  done
+
+let _ = exit 0
+
diff --git a/test/Moretest/tscanf.ml b/test/Moretest/tscanf.ml
new file mode 100644
index 00000000..70b35bfc
--- /dev/null
+++ b/test/Moretest/tscanf.ml
@@ -0,0 +1,848 @@
+open Scanf;;
+
+(* Auxilliaries. *)
+let all_tests_ok = ref true;;
+
+let finish () =
+  match !all_tests_ok with
+  | true ->
+      prerr_endline "\nAll tests succeeded."
+  | _ ->
+      prerr_endline "\n\n********* Test suit failed. ***********\n";;
+
+at_exit finish;;
+
+let test_num = ref (-1);;
+
+let print_test_number () =
+  print_int !test_num; print_string " "; flush stdout;;
+
+let next_test () =
+ incr test_num;
+ print_test_number ();;
+
+let print_test_fail () =
+  all_tests_ok := false;
+  print_string
+   (Printf.sprintf "\n********* Test number %i failed ***********\n"
+    !test_num);;
+
+let print_failure_test_fail () =
+  all_tests_ok := false;
+  print_string
+   (Printf.sprintf
+      "\n********* Failure Test number %i incorrectly failed ***********\n"
+    !test_num);;
+
+let print_failure_test_succeed () =
+  all_tests_ok := false;
+  print_string
+   (Printf.sprintf
+      "\n********* Failure Test number %i failed to fail ***********\n"
+    !test_num);;
+
+let test b =
+ next_test ();
+ if not b then print_test_fail ();;
+
+(* Applies f to x and checks that the evaluation indeed
+   raises an exception that verifies the predicate [pred]. *)
+let test_raises_exc_p pred f x =
+ next_test ();
+ try
+   let b = f x in
+   print_failure_test_succeed ();
+   false
+ with
+ | x ->
+   pred x || (print_failure_test_fail (); false);;
+
+(* Applies f to x and checks that the evaluation indeed
+   raises some exception. *)
+let test_raises_some_exc f = test_raises_exc_p (fun _ -> true) f;;
+let test_raises_this_exc exc = test_raises_exc_p (fun x -> x = exc);;
+
+(* Applies f to x and checks that the evaluation indeed
+   raises exception Failure s. *)
+
+let test_raises_this_failure s f x =
+  test_raises_exc_p (fun x -> x = Failure s) f x;;
+
+(* Applies f to x and checks that the evaluation indeed
+   raises the exception Failure. *)
+let test_raises_some_failure f x =
+  test_raises_exc_p (function Failure _ -> true | _ -> false) f x;;
+
+let failure_test f x s = test_raises_this_failure s f x;;
+let any_failure_test = test_raises_some_failure;;
+
+let scan_failure_test f x =
+  test_raises_exc_p (function Scan_failure _ -> true | _ -> false) f x;;
+
+(* The ``continuation'' that returns the scanned value. *)
+let void x = x;;
+
+(* Testing space scanning. *)
+let test0 () =
+ (sscanf "" "" void) 1 +
+ (sscanf "" " " void) 2 +
+ (sscanf " " " " void) 3 +
+ (sscanf "\t" " " void) 4 +
+ (sscanf "\n" " " void) 5 +
+ (sscanf "\n\t 6" " %d" void)
+;;
+test (test0 () = 21);;
+
+(* Testing integer scanning %i and %d. *)
+let test1 () =
+ sscanf "1" "%d" void +
+ sscanf " 2" " %d" void +
+ sscanf " -2" " %d" void +
+ sscanf " +2" " %d" void +
+ sscanf " 2a " " %da" void;;
+
+test (test1 () = 5);;
+
+let test2 () =
+ sscanf "123" "%2i" void +
+ sscanf "245" "%d" void +
+ sscanf " 2a " " %1da" void;;
+
+test (test2 () = 259);;
+
+let test3 () =
+ sscanf "0xff" "%3i" void +
+ sscanf "0XEF" "%3i" void +
+ sscanf "x=-245" " x = %d" void +
+ sscanf " 2a " " %1da" void;;
+
+test (test3 () = -214);;
+
+(* Testing float scanning. *)
+(* f style. *)
+let test4 () =
+  bscanf (Scanning.from_string "1")
+    "%f" (fun b0 -> b0 = 1.0) &&
+  bscanf (Scanning.from_string "-1")
+    "%f" (fun b0 -> b0 = -1.0) &&
+  bscanf (Scanning.from_string "+1")
+    "%f" (fun b0 -> b0 = 1.0) &&
+  bscanf (Scanning.from_string "1.")
+    "%f" (fun b0 -> b0 = 1.0) &&
+  bscanf (Scanning.from_string ".1")
+    "%f" (fun b0 -> b0 = 0.1) &&
+  bscanf (Scanning.from_string "-.1")
+    "%f" (fun b0 -> b0 = -0.1) &&
+  bscanf (Scanning.from_string "+.1")
+    "%f" (fun b0 -> b0 = 0.1) &&
+  bscanf (Scanning.from_string "+1.")
+    "%f" (fun b0 -> b0 = 1.0) &&
+  bscanf (Scanning.from_string "-1.")
+    "%f" (fun b0 -> b0 = -1.0) &&
+  bscanf (Scanning.from_string "0 1. 1.3")
+    "%f %f %f" (fun b0 b1 b2 -> b0 = 0.0 && b1 = 1.0 && b2 = 1.3) &&
+  bscanf (Scanning.from_string "0.113")
+    "%4f" (fun b0 -> b0 = 0.11) &&
+  bscanf (Scanning.from_string "0.113")
+    "%5f" (fun b0 -> b0 = 0.113) &&
+  bscanf (Scanning.from_string "000.113")
+    "%15f" (fun b0 -> b0 = 0.113) &&
+  bscanf (Scanning.from_string "+000.113")
+    "%15f" (fun b0 -> b0 = 0.113) &&
+  bscanf (Scanning.from_string "-000.113")
+    "%15f" (fun b0 -> b0 = -0.113);;
+test (test4 ());;
+
+(* e style. *)
+let test5 () =
+  bscanf (Scanning.from_string "1e1")
+    "%e" (fun b -> b = 10.0) &&
+  bscanf (Scanning.from_string "1e+1")
+    "%e" (fun b -> b = 10.0) &&
+  bscanf (Scanning.from_string "10e-1")
+    "%e" (fun b -> b = 1.0) &&
+  bscanf (Scanning.from_string "10.e-1")
+    "%e" (fun b -> b = 1.0) &&
+  bscanf (Scanning.from_string "1e1 1.e+1 1.3e-1")
+    "%e %e %e" (fun b1 b2 b3 -> b1 = 10.0 && b2 = b1 && b3 = 0.13) &&
+
+(* g style. *)
+  bscanf (Scanning.from_string "1 1.1 0e+1 1.3e-1")
+    "%g %g %g %g" (fun b1 b2 b3 b4 ->
+                     b1 = 1.0 && b2 = 1.1 && b3 = 0.0 && b4 = 0.13);;
+
+test (test5 ());;
+
+(* Testing boolean scanning. *)
+let test6 () =
+  bscanf (Scanning.from_string "truetrue") "%B%B"
+         (fun b1 b2 -> (b1, b2) = (true, true))  &&
+  bscanf (Scanning.from_string "truefalse") "%B%B"
+         (fun b1 b2 -> (b1, b2) = (true, false)) &&
+  bscanf (Scanning.from_string "falsetrue") "%B%B"
+         (fun b1 b2 -> (b1, b2) = (false, true)) &&
+  bscanf (Scanning.from_string "falsefalse") "%B%B"
+         (fun b1 b2 -> (b1, b2) = (false, false)) &&
+  bscanf (Scanning.from_string "true false") "%B %B"
+         (fun b1 b2 -> (b1, b2) = (true, false));;
+
+test (test6 ());;
+
+(* Testing char scanning. *)
+
+let test7 () =
+  bscanf (Scanning.from_string "'a' '\n' '\t' '\000' '\032'")
+         "%C %C %C %C %C"
+    (fun c1 c2 c3 c4 c5 ->
+       c1 = 'a' && c2 = '\n' && c3 = '\t' && c4 = '\000' && c5 = '\032') &&
+
+(* Here \n, \t, and \032 are skipped due to the space semantics of scanf. *)
+  bscanf (Scanning.from_string "a \n \t \000 \032b")
+         "%c %c %c "
+    (fun c1 c2 c3 ->
+       c1 = 'a' && c2 = '\000' && c3 = 'b');;
+
+test (test7 ());;
+
+let verify_read c =
+  let s = Printf.sprintf "%C" c in
+  let ib = Scanning.from_string s in
+  assert (bscanf ib "%C" void = c);;
+
+let verify_scan_Chars () =
+  for i = 0 to 255 do verify_read (char_of_int i) done;;
+
+let test8 () = verify_scan_Chars () = ();;
+
+test (test8 ());;
+
+(* Testing string scanning. *)
+
+(* %S and %s styles. *)
+let unit fmt s =
+  let ib = Scanning.from_string (Printf.sprintf "%S" s) in
+  Scanf.bscanf ib fmt void;;
+
+let test_fmt fmt s = unit fmt s = s;;
+
+let test_S = test_fmt "%S";;
+let test9 () =
+  test_S "poi" &&
+  test_S "a\"b" &&
+  test_S "a\nb" &&
+  test_S "a\010b" &&
+  test_S "a\\\n\
+          b \\\n\
+          c\010\\\n\
+          b" &&
+  test_S "a\\\n\
+          \\\n\
+          \\\n\
+          b \\\n\
+          c\010\\\n\
+          b"
+;;
+test (test9 ());;
+
+let test10 () =
+  let res = sscanf "Une chaîne: \"celle-ci\" et \"celle-là\"!"
+               "%s %s %S %s %S %s"
+               (fun s1 s2 s3 s4 s5 s6 -> s1 ^ s2 ^ s3 ^ s4 ^ s5 ^ s6) in
+  res = "Unechaîne:celle-cietcelle-là!";;
+
+test (test10 ());;
+
+(* %[] style *)
+let test11 () =
+ sscanf "Pierre	Weis	70" "%s %s %s"
+  (fun prenom nom poids ->
+     prenom = "Pierre" && nom = "Weis" && int_of_string poids = 70)
+ &&
+ sscanf "Jean-Luc	de Léage	68" "%[^	] %[^	] %d"
+  (fun prenom nom poids ->
+     prenom = "Jean-Luc" && nom = "de Léage" && poids = 68)
+ &&
+ sscanf "Daniel	de Rauglaudre	66" "%s@\t %s@\t %d"
+  (fun prenom nom poids ->
+     prenom = "Daniel" && nom = "de Rauglaudre" && poids = 66)
+;;
+
+(* Empty string (end of input) testing. *)
+let test110 () =
+ sscanf "" " " (fun x -> x) "" = "" &&
+ sscanf "" "%s" (fun x -> x = "") &&
+ sscanf "" "%s%s" (fun x y -> x = "" && y = "") &&
+ sscanf "" "%s " (fun x -> x = "") &&
+ sscanf "" " %s" (fun x -> x = "") &&
+ sscanf "" " %s " (fun x -> x = "") &&
+ sscanf "" "%[^\n]" (fun x -> x = "") &&
+ sscanf "" "%[^\n] " (fun x -> x = "") &&
+ sscanf " " "%s" (fun x -> x = "") &&
+ sscanf " " "%s%s" (fun x y -> x = "" && y = "") &&
+ sscanf " " " %s " (fun x -> x = "") &&
+ sscanf " " " %s %s" (fun x y -> x = "" && x = y) &&
+ sscanf " " " %s@ %s" (fun x y -> x = "" && x = y) &&
+ sscanf " poi !" " %s@ %s@." (fun x y -> x = "" && y = "poi!") &&
+ sscanf " poi !" " %s@ %s@." (fun x y -> x = "poi" && y = "!") &&
+ sscanf " poi !" "%s@ %s@." (fun x y -> x = "" && y = "poi !");;
+
+let test111 () =
+ try (sscanf "" "%[^\n]@\n") (fun x -> false) with
+ | End_of_file -> true;;
+
+test (test11 () && test110 () && test111 ());;
+
+(* Scanning lists. *)
+let ib () = Scanning.from_string "[1;2;3;4; ]";;
+
+(* Statically known lists can be scanned directly. *)
+let f ib =
+ bscanf ib " [" ();
+ bscanf ib " %i ;" (fun i ->
+ bscanf ib " %i ;" (fun j ->
+ bscanf ib " %i ;" (fun k ->
+ bscanf ib " %i ;" (fun l ->
+ bscanf ib " ]" ();
+ [i; j; k; l]))));;
+
+let test12 () = f (ib ()) = [1; 2; 3; 4];;
+
+test (test12 ());;
+
+(* A general list scanner that always fails to succeed. *)
+let rec scan_elems ib accu =
+ try bscanf ib " %i ;" (fun i -> scan_elems ib (i :: accu))
+ with _ -> accu;;
+
+let g ib = bscanf ib "[ " (); List.rev (scan_elems ib []);;
+
+let test13 () = g (ib ()) = [1; 2; 3; 4];;
+
+test (test13 ());;
+
+(* A general int list scanner. *)
+let rec scan_int_list ib =
+ bscanf ib "[ " ();
+ let accu = scan_elems ib [] in
+ bscanf ib " ]" ();
+ List.rev accu;;
+
+let test14 () = scan_int_list (ib ()) = [1; 2; 3; 4];;
+
+test (test14 ());;
+
+(* A general list scanner that always succeeds. *)
+let rec scan_elems ib accu =
+  bscanf ib " %i %c"
+   (fun i -> function
+    | ';' -> scan_elems ib (i :: accu)
+    | ']' -> List.rev (i :: accu)
+    | c -> failwith "scan_elems");;
+
+let rec scan_int_list ib =
+ bscanf ib "[ " ();
+ scan_elems ib [];;
+
+let test15 () =
+  scan_int_list (Scanning.from_string "[1;2;3;4]") = [1; 2; 3; 4];;
+
+test (test15 ());;
+
+let rec scan_elems ib accu =
+  try
+  bscanf ib "%c %i"
+   (fun c i ->
+    match c with
+    | ';' -> scan_elems ib (i :: accu)
+    | ']' -> List.rev (i :: accu)
+    | '[' when accu = [] -> scan_elems ib (i :: accu)
+    | c -> prerr_endline (String.make 1 c); failwith "scan_elems")
+  with
+  | Scan_failure _ -> bscanf ib "]" (); accu
+  | End_of_file -> accu;;
+
+let scan_int_list ib = scan_elems ib [];;
+
+let test16 () =
+  scan_int_list (Scanning.from_string "[]") = List.rev [] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4]") = List.rev [1;2;3;4] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4; ]") = List.rev [1;2;3;4] &&
+  (* Should fail but succeeds! *)
+  scan_int_list (Scanning.from_string "[1;2;3;4") = List.rev [1;2;3;4]
+;;
+
+test (test16 ());;
+
+let rec scan_elems ib accu =
+  bscanf ib " %i%[]; \t\n\r]"
+   (fun i s ->
+    match s with
+    | ";" -> scan_elems ib (i :: accu)
+    | "]" -> List.rev (i :: accu)
+    | s -> List.rev (i :: accu));;
+
+let scan_int_list ib =
+ bscanf ib " [" ();
+ scan_elems ib [];;
+
+let test17 () =
+  scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4; ]") = [1;2;3;4] &&
+  (* Should fail but succeeds! *)
+  scan_int_list (Scanning.from_string "[1;2;3;4 5]") = [1;2;3;4]
+;;
+
+test (test17 ());;
+
+let rec scan_elems ib accu =
+  bscanf ib " %c " (fun c ->
+    match c with
+    | '[' when accu = [] ->
+        (* begginning of list: could find either
+           - an int, if the list is not empty,
+           - the char ], if the list is empt *)
+        bscanf ib "%[]]"
+         (function
+          | "]" -> accu
+          | _ ->
+           bscanf ib " %i " (fun i ->
+            scan_rest ib (i :: accu)))
+    | _ -> failwith "scan_elems")
+
+and scan_rest ib accu =
+  bscanf ib " %c " (fun c ->
+    match c with
+    | ';' ->
+        bscanf ib "%[]]"
+         (function
+          | "]" -> accu
+          | _ ->
+            bscanf ib " %i " (fun i ->
+            scan_rest ib (i :: accu)))
+    | ']' -> accu
+    | _ -> failwith "scan_rest");;
+
+
+let scan_int_list ib = List.rev (scan_elems ib []);;
+
+let test18 () =
+  scan_int_list (Scanning.from_string "[]") = [] &&
+  scan_int_list (Scanning.from_string "[ ]") = [] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4; ]") = [1;2;3;4]
+;;
+
+test (test18 ());;
+
+(* Those properly fail *)
+
+let test19 () =
+ failure_test
+   scan_int_list (Scanning.from_string "[1;2;3;4 5]")
+   "scan_rest";;
+
+(test19 ());;
+
+let test20 () =
+  scan_failure_test 
+   scan_int_list (Scanning.from_string "[1;2;3;4; ; 5]");;
+
+(test20 ());;
+
+let test21 () =
+ scan_failure_test
+   scan_int_list (Scanning.from_string "[1;2;3;4;;");;
+
+(test21 ());;
+
+let rec scan_elems ib accu =
+  bscanf ib "%1[];]" (function
+  | "]" -> accu
+  | ";" -> scan_rest ib accu
+  | _ ->
+     failwith
+      (Printf.sprintf "scan_int_list" (*
+        "scan_int_list: char %i waiting for ']' or ';' but found %c"
+        (Scanning.char_count ib) (Scanning.peek_char ib)*)))
+
+and scan_rest ib accu =
+ bscanf ib "%[]]" (function
+ | "]" -> accu
+ | _ -> scan_elem ib accu)
+
+and scan_elem ib accu =
+  bscanf ib " %i " (fun i -> scan_elems ib (i :: accu));;
+
+let scan_int_list ib =
+ bscanf ib " [ " ();
+ List.rev (scan_rest ib []);;
+
+let test22 () =
+  scan_int_list (Scanning.from_string "[]") = [] &&
+  scan_int_list (Scanning.from_string "[ ]") = [] &&
+  scan_int_list (Scanning.from_string "[1]") = [1] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4];;
+
+test (test22 ());;
+
+(* Should work and does not with this version of scan_int_list!
+scan_int_list (Scanning.from_string "[1;2;3;4; ]");;
+(* Should lead to a bad input error. *)
+scan_int_list (Scanning.from_string "[1;2;3;4 5]");;
+scan_int_list (Scanning.from_string "[1;2;3;4;;");;
+scan_int_list (Scanning.from_string "[1;2;3;4; ; 5]");;
+scan_int_list (Scanning.from_string "[1;2;3;4;; 23]");;
+*)
+
+let rec scan_elems ib accu =
+ try bscanf ib " %i %1[;]" (fun i s ->
+  if s = "" then i :: accu else scan_elems ib (i :: accu))
+ with Scan_failure _ -> accu;;
+
+(* The general int list scanner. *)
+let rec scan_int_list ib =
+ bscanf ib "[ " ();
+ let accu = scan_elems ib [] in
+ bscanf ib " ]" ();
+ List.rev accu;;
+
+(* The general HO list scanner. *)
+let rec scan_elems ib scan_elem accu =
+ try scan_elem ib (fun i s ->
+  let accu = i :: accu in
+  if s = "" then accu else scan_elems ib scan_elem accu)
+ with Scan_failure _ -> accu;;
+
+let scan_list scan_elem ib =
+ bscanf ib "[ " ();
+ let accu = scan_elems ib scan_elem [] in
+ bscanf ib " ]" ();
+ List.rev accu;;
+
+(* Deriving particular list scanners from the HO list scanner. *)
+let scan_int_elem ib = bscanf ib " %i %1[;]";;
+let scan_int_list = scan_list scan_int_elem;;
+
+let test23 () =
+  scan_int_list (Scanning.from_string "[]") = [] &&
+  scan_int_list (Scanning.from_string "[ ]") = [] &&
+  scan_int_list (Scanning.from_string "[1]") = [1] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4]
+;;
+
+test (test23 ());;
+
+let test24 () =
+  scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4 5]")
+and test25 () =
+  scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4;;")
+and test26 () =
+  scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4; ; 5]")
+and test27 () =
+  scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4;; 23]");;
+
+ (test24 ()) &&
+ (test25 ()) &&
+ (test26 ()) &&
+ (test27 ());;
+
+(* To scan a Caml string:
+   the format is "\"%s@\"".
+   A better way would be to add a %S (String.escaped), a %C (Char.escaped).
+   This is now available. *)
+let scan_string_elem ib = bscanf ib " \"%s@\" %1[;]";;
+let scan_string_list = scan_list scan_string_elem;;
+
+let scan_String_elem ib = bscanf ib " %S %1[;]";;
+let scan_String_list = scan_list scan_String_elem;;
+
+let test28 () =
+  scan_string_list (Scanning.from_string "[]") = [] &&
+  scan_string_list (Scanning.from_string "[\"Le\"]") = ["Le"] &&
+  scan_string_list
+    (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"]") =
+    ["Le"; "langage"; "Objective"; "Caml"] &&
+  scan_string_list
+    (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"; ]") =
+    ["Le"; "langage"; "Objective"; "Caml"] &&
+
+  scan_String_list (Scanning.from_string "[]") = [] &&
+  scan_String_list (Scanning.from_string "[\"Le\"]") = ["Le"] &&
+  scan_String_list
+    (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"]") =
+    ["Le"; "langage"; "Objective"; "Caml"] &&
+  scan_String_list
+    (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"; ]") =
+    ["Le"; "langage"; "Objective"; "Caml"]
+;;
+
+test (test28 ());;
+
+(* The general HO list scanner with continuations. *)
+let rec scan_elems ib scan_elem accu =
+ scan_elem ib
+  (fun i s ->
+     let accu = i :: accu in
+     if s = "" then accu else scan_elems ib scan_elem accu)
+  (fun ib exc -> accu);;
+
+let scan_list scan_elem ib =
+ bscanf ib "[ " ();
+ let accu = scan_elems ib scan_elem [] in
+ bscanf ib " ]" ();
+ List.rev accu;;
+
+(* Deriving particular list scanners from the HO list scanner. *)
+let scan_int_elem ib f ek = kscanf ib ek " %i %1[;]" f;;
+let scan_int_list = scan_list scan_int_elem;;
+
+let test29 () =
+  scan_int_list (Scanning.from_string "[]") = [] &&
+  scan_int_list (Scanning.from_string "[ ]") = [] &&
+  scan_int_list (Scanning.from_string "[1]") = [1] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4]
+;;
+
+test (test29 ());;
+
+let scan_string_elem ib f ek = kscanf ib ek " %S %1[;]" f;;
+let scan_string_list = scan_list scan_string_elem;;
+
+let test30 () =
+  scan_string_list (Scanning.from_string "[]") = [] &&
+  scan_string_list (Scanning.from_string "[ ]") = [] &&
+  scan_string_list (Scanning.from_string "[ \"1\" ]") = ["1"] &&
+  scan_string_list
+    (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\"]") =
+    ["1"; "2"; "3"; "4"] &&
+  scan_string_list
+    (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\";]") =
+    ["1"; "2"; "3"; "4"]
+;;
+
+test (test30 ());;
+
+(* A generic scan_elem, *)
+let scan_elem fmt ib f ek = kscanf ib ek fmt f;;
+
+(* Derivation of list scanners from the generic polymorphic scanners. *)
+let scan_int_list = scan_list (scan_elem " %i %1[;]");;
+let scan_string_list = scan_list (scan_elem " %S %1[;]");;
+let scan_bool_list = scan_list (scan_elem " %B %1[;]");;
+let scan_char_list = scan_list (scan_elem " %C %1[;]");;
+let scan_float_list = scan_list (scan_elem " %f %1[;]");;
+
+let rec scan_elems ib scan_elem accu =
+ scan_elem ib
+  (fun i ->
+     let accu = i :: accu in
+     kscanf ib
+      (fun ib exc -> accu)
+      " %1[;]"
+      (fun s -> if s = "" then accu else scan_elems ib scan_elem accu))
+  (fun ib exc -> accu);;
+
+let scan_list scan_elem ib =
+ bscanf ib "[ " ();
+ let accu = scan_elems ib scan_elem [] in
+ bscanf ib " ]" ();
+ List.rev accu;;
+
+let scan_int_list = scan_list (scan_elem " %i");;
+let scan_string_list = scan_list (scan_elem " %S");;
+let scan_bool_list = scan_list (scan_elem " %B");;
+let scan_char_list = scan_list (scan_elem " %C");;
+let scan_float_list = scan_list (scan_elem " %f");;
+
+let test31 () =
+  scan_int_list (Scanning.from_string "[]") = [] &&
+  scan_int_list (Scanning.from_string "[ ]") = [] &&
+  scan_int_list (Scanning.from_string "[1]") = [1] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] &&
+  scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4]
+;;
+
+test (test31 ());;
+
+let test32 () =
+  scan_string_list (Scanning.from_string "[]") = [] &&
+  scan_string_list (Scanning.from_string "[ ]") = [] &&
+  scan_string_list (Scanning.from_string "[ \"1\" ]") = ["1"] &&
+  scan_string_list
+    (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\"]") =
+    ["1"; "2"; "3"; "4"] &&
+  scan_string_list
+    (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\";]") =
+    ["1"; "2"; "3"; "4"]
+;;
+
+test (test32 ());;
+
+(* Using kscanf only. *)
+let rec scan_elems ib scan_elem accu =
+  kscanf ib (fun ib exc -> accu)
+   scan_elem
+   (fun i ->
+      let accu = i :: accu in
+      kscanf ib (fun ib exc -> accu)
+       " %1[;] "
+       (fun s -> if s = "" then accu else scan_elems ib scan_elem accu))
+;;
+
+let scan_list scan_elem ib =
+  bscanf ib "[ " ();
+  let accu = scan_elems ib scan_elem [] in
+  bscanf ib " ]" ();
+  List.rev accu
+;;
+
+let scan_int_list = scan_list "%i";;
+let scan_string_list = scan_list "%S";;
+let scan_bool_list = scan_list "%B";;
+let scan_char_list = scan_list "%C";;
+let scan_float_list = scan_list "%f";;
+
+let test33 () =
+  scan_int_list (Scanning.from_string "[]") = [] &&
+  scan_int_list (Scanning.from_string "[ ]") = [] &&
+  scan_int_list (Scanning.from_string "[ 1 ]") = [1] &&
+  scan_int_list (Scanning.from_string "[ 1 ; 2 ; 3 ; 4 ]") = [1; 2; 3; 4] &&
+  scan_int_list (Scanning.from_string "[1 ;2 ;3 ;4;]") = [1; 2; 3; 4]
+;;
+
+test (test33 ());;
+
+let test34 () =
+  scan_string_list (Scanning.from_string "[]") = [] &&
+  scan_string_list (Scanning.from_string "[ ]") = [] &&
+  scan_string_list (Scanning.from_string "[ \"1\" ]") = ["1"] &&
+  scan_string_list
+    (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\"]") =
+    ["1"; "2"; "3"; "4"] &&
+  scan_string_list
+    (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\";]") =
+    ["1"; "2"; "3"; "4"]
+;;
+
+test (test34 ());;
+
+(* Testing the %N format. *)
+let test35 () =
+  sscanf "" "%N" (fun x -> x) = 0 &&
+  sscanf "456" "%N" (fun x -> x) = 0 &&
+  sscanf "456" "%d%N" (fun x y -> x, y) = (456, 1) &&
+  sscanf " " "%N%s%N" (fun x s y -> x, s, y) = (0, "", 1)
+;;
+
+test (test35 ());;
+
+(* Testing the %n format. *)
+let test36 () =
+  sscanf "" "%n" (fun x -> x) = 0 &&
+  sscanf "456" "%n" (fun x -> x) = 0 &&
+  sscanf "456" "%d%n" (fun x y -> x, y) = (456, 3) &&
+  sscanf " " "%n%s%n" (fun x s y -> x, s, y) = (0, "", 1)
+;;
+
+test (test36 ());;
+
+(* Weird tests to empty strings or formats. *)
+let test37 () =
+  sscanf "" "" true &&
+  sscanf "" "" (fun x -> x) 1 = 1 &&
+  sscanf "123" "" (fun x -> x) 1 = 1
+;;
+
+test (test37 ());;
+
+(* Testing end of input condition. *)
+let test38 () =
+  sscanf " " " %!" true &&
+  sscanf "" " %!" true &&
+  sscanf "" "%!" true;;
+
+test (test38 ());;
+
+(* Weird tests on empty buffers. *)
+let test39 () =
+  let is_empty_buff ib =
+    Scanning.beginning_of_input ib &&
+    Scanning.end_of_input ib in
+
+  let ib = Scanning.from_string "" in
+  is_empty_buff ib &&
+  (* Do it twice since testing empty buff could incorrectly
+     thraw an exception or wrongly change the beginning_of_input condition. *)
+  is_empty_buff ib;;
+
+test (test39 ());;
+
+(* Testing ranges. *)
+let test40 () =
+ let s = "cba" in
+ let ib = Scanning.from_string s in
+ bscanf ib "%[^ab]%s%!" (fun s1 s2 -> s1 = "c" && s2 = "ba");;
+
+test (test40 ());;
+
+let test41 () =
+ let s = "cba" in
+ let ib = Scanning.from_string s in
+ bscanf ib "%[^abc]%[cba]%!" (fun s1 s2 -> s1 = "" && s2 = "cba");;
+
+test (test41 ());;
+
+let test42 () =
+ let s = "defcbaaghi" in
+ let ib = Scanning.from_string s in
+ bscanf ib "%[^abc]%[cba]%s%!" (fun s1 s2 s3 ->
+   s1 = "def" && s2 = "cbaa" && s3 = "ghi");;
+
+test (test42 ());;
+
+let test50 () =
+ let s = "12.2" in
+ let ib = Scanning.from_string s in
+ bscanf ib "%[0-9].%[0-9]%s%!" (fun s1 s2 s3 ->
+   s1 = "12" && s2 = "2" && s3 = "");;
+
+test (test50 ());;
+
+(*******
+
+print_string "Test number is "; 
+print_int !test_num; print_string ". It should be 42.";
+print_newline();;
+
+To be continued.
+
+let digest () =
+  let scan_line f = Scanf.scanf "%[^\n\r]@\n" f in
+  let digest s = String.uppercase (Digest.to_hex (Digest.string s)) in
+  let digest_line s = print_endline (s ^ "#" ^ digest s) in
+  try
+   while true do scan_line digest_line done
+  with End_of_file -> ()
+;;
+
+(* Trying to scan records. *)
+let rec scan_fields ib scan_field accu =
+  kscanf ib (fun ib exc -> accu)
+   scan_field
+   (fun i ->
+      let accu = i :: accu in
+      kscanf ib (fun ib exc -> accu)
+       " %1[;] "
+       (fun s -> if s = "" then accu else scan_fields ib scan_field accu))
+;;
+
+let scan_record scan_field ib =
+  bscanf ib "{ " ();
+  let accu = scan_fields ib scan_field [] in
+  bscanf ib " }" ();
+  List.rev accu
+;;
+***********)
diff --git a/test/Moretest/usemultdef.ml b/test/Moretest/usemultdef.ml
new file mode 100644
index 00000000..2bccabb6
--- /dev/null
+++ b/test/Moretest/usemultdef.ml
@@ -0,0 +1 @@
+let _ = print_int(Multdef.f 1); print_newline(); exit 0
diff --git a/test/Moretest/warnings.ml b/test/Moretest/warnings.ml
new file mode 100644
index 00000000..08e2f291
--- /dev/null
+++ b/test/Moretest/warnings.ml
@@ -0,0 +1,44 @@
+
+(* C *)
+
+let foo = ( *);;
+
+
+(* F *)
+
+let f x y = x;;
+f 1; f 1;;
+
+
+(* M *)
+
+(* duh *)
+
+
+(* P *)
+
+let 1 = 1;;
+
+
+(* S *)
+
+1; 1;;
+
+
+(* U *)
+
+match 1 with
+| 1 -> ()
+| 1 -> ()
+| _ -> ()
+;;
+
+
+(* V *)
+
+(* re-duh *)
+
+
+(* X *)
+
+(* re-re *)
diff --git a/test/Moretest/wc.ml b/test/Moretest/wc.ml
new file mode 100644
index 00000000..dbe46d9a
--- /dev/null
+++ b/test/Moretest/wc.ml
@@ -0,0 +1,54 @@
+(* Counts characters, lines and words in one or several files. *)
+
+let chars = ref 0
+and words = ref 0
+and lines = ref 0
+
+type state = Inside_word | Outside_word
+
+let count_channel in_channel =
+  let rec count status =
+    let c = input_char in_channel in
+    incr chars;
+    match c with
+      '\n' ->
+        incr lines; count Outside_word
+    | ' ' | '\t' ->
+        count Outside_word
+    | _ ->
+        if status = Outside_word then begin incr words; () end;
+        count Inside_word
+  in
+    try
+      count Outside_word
+    with End_of_file ->
+      ()
+
+let count_file name =
+  let ic = open_in name in
+  count_channel ic;
+  close_in ic
+
+let print_result () =
+  print_int !chars; print_string " characters, ";
+  print_int !words; print_string " words, ";
+  print_int !lines; print_string " lines";
+  print_newline()
+
+let count name =
+  count_file name;
+  print_result ()
+
+let _ =
+try
+  if Array.length Sys.argv <= 1 then
+    count_channel stdin                (* No command-line arguments *)
+  else
+    for i = 1 to Array.length Sys.argv - 1 do
+      count_file  Sys.argv.(i)
+    done;
+  print_result ()
+with Sys_error s ->
+  print_string "I/O error: ";
+  print_string s;
+  print_newline()
diff --git a/test/Results/almabench.fast.out b/test/Results/almabench.fast.out
new file mode 100644
index 00000000..5c1d8b89
--- /dev/null
+++ b/test/Results/almabench.fast.out
@@ -0,0 +1,8 @@
+0 17.00 -26.06
+1 12.34 1.29
+2 6.83 22.95
+3 0.04 -1.26
+4 2.30 12.54
+5 2.93 14.35
+6 21.27 -16.57
+7 20.41 -19.04
diff --git a/test/Results/almabench.out b/test/Results/almabench.out
new file mode 100644
index 00000000..5c1d8b89
--- /dev/null
+++ b/test/Results/almabench.out
@@ -0,0 +1,8 @@
+0 17.00 -26.06
+1 12.34 1.29
+2 6.83 22.95
+3 0.04 -1.26
+4 2.30 12.54
+5 2.93 14.35
+6 21.27 -16.57
+7 20.41 -19.04
diff --git a/test/Results/bdd.out b/test/Results/bdd.out
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/test/Results/bdd.out
@@ -0,0 +1 @@
+OK
diff --git a/test/Results/boyer.out b/test/Results/boyer.out
new file mode 100644
index 00000000..f38e3263
--- /dev/null
+++ b/test/Results/boyer.out
@@ -0,0 +1 @@
+Proved!
diff --git a/test/Results/fft.fast.runtest b/test/Results/fft.fast.runtest
new file mode 100644
index 00000000..16f24bdb
--- /dev/null
+++ b/test/Results/fft.fast.runtest
@@ -0,0 +1,4 @@
+case $1 in
+  test)  shift; $*  | awk '$2 >= 1e-9 { exit 2; }';;
+  bench) shift; xtime -o /dev/null $*;;
+esac
\ No newline at end of file
diff --git a/test/Results/fft.runtest b/test/Results/fft.runtest
new file mode 100644
index 00000000..16f24bdb
--- /dev/null
+++ b/test/Results/fft.runtest
@@ -0,0 +1,4 @@
+case $1 in
+  test)  shift; $*  | awk '$2 >= 1e-9 { exit 2; }';;
+  bench) shift; xtime -o /dev/null $*;;
+esac
\ No newline at end of file
diff --git a/test/Results/fib.out b/test/Results/fib.out
new file mode 100644
index 00000000..08c2ab3e
--- /dev/null
+++ b/test/Results/fib.out
@@ -0,0 +1 @@
+1346269
diff --git a/test/Results/genlex.runtest b/test/Results/genlex.runtest
new file mode 100644
index 00000000..b9638e1f
--- /dev/null
+++ b/test/Results/genlex.runtest
@@ -0,0 +1,5 @@
+case $1 in
+  test) shift; $* Lex/testscanner.mll;;
+  bench) shift; xtime -o /dev/null -e /dev/null -repeat 3 $* Lex/testscanner.mll;;
+esac
+
diff --git a/test/Results/hamming.out b/test/Results/hamming.out
new file mode 100644
index 00000000..af1339ef
--- /dev/null
+++ b/test/Results/hamming.out
@@ -0,0 +1,100 @@
+6726050156250000000000000000000000000
+6729216728661136606575523242669244416
+6730293634611118019721084375000000000
+6731430439413948088320000000000000000
+6733644878411293029785156250000000000
+6736815026358904613608094481682268160
+6739031236724077363200000000000000000
+6743282904874568941599068856042651648
+6744421903677486140423997176256921600
+6746640616477458432000000000000000000
+6750000000000000000000000000000000000
+6750897085400702945836103937453588480
+6752037370304563380023474956271616000
+6754258588364960445000000000000000000
+6755399441055744000000000000000000000
+6757621765136718750000000000000000000
+6758519863481752323552044362431792300
+6759661435938757375539248533340160000
+6761885162088395001166534423828125000
+6763027302973440000000000000000000000
+6765252136392518877983093261718750000
+6767294110289640371843415775641600000
+6768437164792816653010961694720000000
+6770663777894400000000000000000000000
+6774935403077748181101173538816000000
+6776079748261363229431903027200000000
+6778308875544000000000000000000000000
+6782585324034592562287109312160000000
+6783730961356018699387011072000000000
+6785962605658597412109375000000000000
+6789341568946838378906250000000000000
+6791390813820928754681118720000000000
+6794772480000000000000000000000000000
+6799059315411241693033267200000000000
+6800207735332289107722240000000000000
+6802444800000000000000000000000000000
+6806736475893120841673472000000000000
+6807886192552970708582400000000000000
+6810125783203125000000000000000000000
+6814422305043756994967597929687500000
+6815573319906622439424000000000000000
+6817815439391434192657470703125000000
+6821025214188390921278195662703296512
+6821210263296961784362792968750000000
+6823269127183128330240000000000000000
+6828727177473454717179297140960133120
+6830973624183426662400000000000000000
+6834375000000000000000000000000000000
+6835283298968211732659055236671758336
+6836437837433370422273768393225011200
+6838686820719522450562500000000000000
+6839841934068940800000000000000000000
+6842092037200927734375000000000000000
+6844157203887991842733489140006912000
+6845313241232438768082197309030400000
+6847565144260608000000000000000000000
+6849817788097425363957881927490234375
+6851885286668260876491458472837120000
+6853042629352726861173598715904000000
+6855297075118080000000000000000000000
+6859622095616220033364938208051200000
+6860780745114630269799801815040000000
+6863037736488300000000000000000000000
+6866455078125000000000000000000000000
+6867367640585024969315698178562000000
+6868527598372968933129348710400000000
+6870787138229329879760742187500000000
+6871947673600000000000000000000000000
+6874208338558673858642578125000000000
+6876283198993690364114632704000000000
+6879707136000000000000000000000000000
+6884047556853882214196183040000000000
+6885210332023942721568768000000000000
+6887475360000000000000000000000000000
+6891820681841784852194390400000000000
+6892984769959882842439680000000000000
+6895252355493164062500000000000000000
+6899602583856803957404692903808593750
+6900767986405455219916800000000000000
+6903038132383827120065689086914062500
+6906475391588173806667327880859375000
+6908559991272917434368000000000000000
+6912000000000000000000000000000000000
+6914086267191872901144038355222134784
+6916360794485719495680000000000000000
+6917529027641081856000000000000000000
+6919804687500000000000000000000000000
+6921893310401287552552190498140323840
+6924170405978516481194531250000000000
+6925339958244802560000000000000000000
+6927618187665939331054687500000000000
+6929709168936591740767657754256998400
+6930879656747844252683224775393280000
+6933159708563865600000000000000000000
+6937533852751614137447601703747584000
+6938705662219635946938268699852800000
+6940988288557056000000000000000000000
+6945367371811422783781999935651840000
+6946540504428563148172299337728000000
+6948825708194403750000000000000000000
diff --git a/test/Results/kb.out b/test/Results/kb.out
new file mode 100644
index 00000000..758a0b4d
--- /dev/null
+++ b/test/Results/kb.out
@@ -0,0 +1,273 @@
+1 : U*v1 = v1
+2 : I(v1)*v1 = U
+3 : (v3*v2)*v1 = v3*(v2*v1)
+4 : A*B = B*A
+5 : C*C = U
+6 : I(A) = C*(A*I(C))
+7 : C*(B*I(C)) = B
+8 : I(v2)*(v2*v1) = v1
+9 : A*(B*v1) = B*(A*v1)
+10 : C*(C*v1) = v1
+11 : C*(A*(I(C)*A)) = U
+12 : C*(B*(I(C)*v1)) = B*v1
+13 : I(U)*v1 = v1
+14 : I(I(v1))*U = v1
+15 : I(v3*v2)*(v3*(v2*v1)) = v1
+16 : C*(A*(I(C)*(B*A))) = B
+17 : I(C)*U = C
+18 : C*(A*(I(C)*(A*v1))) = v1
+19 : I(C)*B = B*I(C)
+20 : I(I(v2))*v1 = v2*v1
+Rule 14 deleted
+21 : v1*U = v1
+Rule 17 deleted
+22 : I(C) = C
+Rule 19 deleted
+Rule 18 deleted
+Rule 16 deleted
+Rule 12 deleted
+Rule 11 deleted
+Rule 7 deleted
+23 : C*B = B*C
+24 : C*(A*(C*(A*v1))) = v1
+25 : C*(A*(C*(B*A))) = B
+26 : C*(B*(C*v1)) = B*v1
+27 : C*(A*(C*A)) = U
+28 : C*(B*C) = B
+29 : C*(A*(C*(B*(A*v1)))) = B*v1
+30 : I(I(v2*v1)*v2) = v1
+31 : I(v2*I(v1))*v2 = v1
+32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1
+33 : I(v1*A)*(v1*(B*A)) = B
+34 : I(v1*C)*v1 = C
+35 : I(v3*I(v2))*(v3*v1) = v2*v1
+36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1
+37 : I(v2*C)*(v2*v1) = C*v1
+38 : v1*I(v1) = U
+39 : I(C*(A*C))*v1 = A*v1
+40 : v2*(I(v2)*v1) = v1
+41 : I(U) = U
+Rule 13 deleted
+42 : I(I(v1)) = v1
+Rule 20 deleted
+43 : C*(B*v1) = B*(C*v1)
+Rule 29 deleted
+Rule 28 deleted
+Rule 26 deleted
+Rule 25 deleted
+44 : A*(C*(A*v1)) = C*v1
+Rule 24 deleted
+45 : A*(C*A) = C
+Rule 27 deleted
+46 : v2*(I(v1*v2)*v1) = U
+47 : I(I(v3*(v2*v1))*(v3*v2)) = v1
+48 : I(I(B*A)*A) = B
+49 : v3*(I(v2*v3)*(v2*v1)) = v1
+50 : I(I(v1)*I(v2)) = v2*v1
+51 : I(I(B*(A*v1))*A) = B*v1
+52 : I(I(v1)*C) = C*v1
+53 : I(v2*I(v1*v2)) = v1
+54 : I(v3*(v2*I(v1)))*(v3*v2) = v1
+55 : I(v1*(C*(A*C)))*v1 = A
+56 : v2*I(I(v1)*v2) = v1
+57 : I(v2*(I(v3*v1)*v3))*v2 = v1
+58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1
+59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B
+60 : I(v2*(v1*C))*(v2*v1) = C
+61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1
+62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1
+63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1
+64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1
+65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1
+66 : I(I(B)*A)*A = B
+67 : I(A*A)*(B*(A*A)) = B
+68 : v1*(I(A*v1)*(B*A)) = B
+69 : I(I(v1*A)*(v1*B))*B = A
+70 : v1*I(C*v1) = C
+71 : I(A*I(v1))*(B*A) = v1*B
+72 : I(C*I(v1)) = v1*C
+73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1
+74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1)
+75 : v3*(I(I(v2)*v3)*v1) = v2*v1
+76 : I(I(B*I(v1))*A)*(v1*A) = B
+77 : I(v1*A)*(v1*(B*(B*A))) = B*B
+78 : I(I(B)*A)*(A*v1) = B*v1
+79 : I(A*A)*(B*(A*(A*v1))) = B*v1
+80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1)
+81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1
+82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1
+83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1
+84 : I(A*C)*(B*A) = B*C
+85 : I(A*C)*(B*(A*v1)) = B*(C*v1)
+86 : v2*(I(C*v2)*v1) = C*v1
+87 : I(I(B*C)*A)*(C*A) = B
+88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1
+89 : v2*(v1*I(v2*v1)) = U
+90 : B*(A*I(B)) = A
+91 : I(v2*v1)*v2 = I(v1)
+Rule 64 deleted
+Rule 57 deleted
+Rule 55 deleted
+Rule 46 deleted
+Rule 34 deleted
+Rule 31 deleted
+Rule 30 deleted
+92 : I(C*(A*C)) = A
+Rule 39 deleted
+93 : I(v3*(v2*v1))*(v3*v2) = I(v1)
+Rule 60 deleted
+Rule 54 deleted
+Rule 47 deleted
+94 : I(v1*I(v2)) = v2*I(v1)
+Rule 83 deleted
+Rule 76 deleted
+Rule 74 deleted
+Rule 72 deleted
+Rule 71 deleted
+Rule 53 deleted
+Rule 50 deleted
+Rule 35 deleted
+95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1
+96 : I(v1*(I(B)*A))*(v1*A) = B
+97 : I(v1*A)*(v1*B) = B*(C*(A*C))
+Rule 82 deleted
+Rule 69 deleted
+98 : I(v1*C) = C*I(v1)
+Rule 88 deleted
+Rule 87 deleted
+Rule 85 deleted
+Rule 84 deleted
+Rule 52 deleted
+Rule 37 deleted
+99 : v3*(v2*(I(v3*v2)*v1)) = v1
+100 : B*(A*(I(B)*v1)) = A*v1
+101 : I(v3*v2)*(v3*v1) = I(v2)*v1
+Rule 97 deleted
+Rule 96 deleted
+Rule 95 deleted
+Rule 93 deleted
+Rule 80 deleted
+Rule 77 deleted
+Rule 73 deleted
+Rule 65 deleted
+Rule 63 deleted
+Rule 62 deleted
+Rule 61 deleted
+Rule 59 deleted
+Rule 58 deleted
+Rule 49 deleted
+Rule 36 deleted
+Rule 33 deleted
+Rule 32 deleted
+Rule 15 deleted
+102 : B*(C*I(B)) = C
+103 : B*(C*(I(B)*v1)) = C*v1
+104 : B*(I(B*A)*A) = U
+105 : B*(I(B*A)*(A*v1)) = v1
+106 : I(B*A)*A = I(B)
+Rule 104 deleted
+Rule 48 deleted
+107 : B*(v1*(I(B*(A*v1))*A)) = U
+108 : I(I(B*(B*A))*A) = B*B
+109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1
+110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1)
+111 : I(I(B)*A) = B*(C*(A*C))
+Rule 78 deleted
+Rule 66 deleted
+112 : I(I(B*v1)*A) = B*(C*(A*(C*v1)))
+Rule 110 deleted
+Rule 108 deleted
+Rule 51 deleted
+113 : v3*(v2*I(I(v1)*(v3*v2))) = v1
+114 : v1*I(C*(A*(C*v1))) = A
+115 : I(I(v1)*v2) = I(v2)*v1
+Rule 113 deleted
+Rule 112 deleted
+Rule 111 deleted
+Rule 75 deleted
+Rule 56 deleted
+116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B
+117 : I(A*v1)*(B*A) = I(v1)*B
+Rule 116 deleted
+Rule 68 deleted
+118 : v2*(v1*I(C*(v2*v1))) = C
+119 : I(C*v1) = I(v1)*C
+Rule 118 deleted
+Rule 114 deleted
+Rule 92 deleted
+Rule 86 deleted
+Rule 70 deleted
+120 : v1*(I(A*(C*v1))*C) = A
+121 : I(A*A)*(B*(B*(A*A))) = B*B
+122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1)
+123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1)))
+Rule 79 deleted
+Rule 67 deleted
+124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1
+125 : v1*(I(A*v1)*(B*(B*A))) = B*B
+126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1)
+Rule 124 deleted
+Rule 123 deleted
+Rule 81 deleted
+127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U
+128 : v2*I(v1*v2) = I(v1)
+Rule 89 deleted
+129 : A*I(B) = I(B)*A
+Rule 90 deleted
+130 : I(v1*v2) = I(v2)*I(v1)
+Rule 128 deleted
+Rule 127 deleted
+Rule 126 deleted
+Rule 125 deleted
+Rule 122 deleted
+Rule 121 deleted
+Rule 120 deleted
+Rule 119 deleted
+Rule 117 deleted
+Rule 115 deleted
+Rule 109 deleted
+Rule 107 deleted
+Rule 106 deleted
+Rule 105 deleted
+Rule 101 deleted
+Rule 99 deleted
+Rule 98 deleted
+Rule 94 deleted
+Rule 91 deleted
+131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1
+132 : B*(C*(A*(C*(I(B)*A)))) = U
+133 : C*(A*(C*(I(B)*A))) = I(B)
+Rule 132 deleted
+134 : A*(I(B)*v1) = I(B)*(A*v1)
+Rule 100 deleted
+135 : C*I(B) = I(B)*C
+Rule 102 deleted
+136 : C*(I(B)*v1) = I(B)*(C*v1)
+Rule 133 deleted
+Rule 131 deleted
+Rule 103 deleted
+Canonical set found :
+1 : U*v1 = v1
+2 : I(v1)*v1 = U
+3 : (v3*v2)*v1 = v3*(v2*v1)
+4 : A*B = B*A
+5 : C*C = U
+6 : I(A) = C*(A*C)
+8 : I(v2)*(v2*v1) = v1
+9 : A*(B*v1) = B*(A*v1)
+10 : C*(C*v1) = v1
+21 : v1*U = v1
+22 : I(C) = C
+23 : C*B = B*C
+38 : v1*I(v1) = U
+40 : v2*(I(v2)*v1) = v1
+41 : I(U) = U
+42 : I(I(v1)) = v1
+43 : C*(B*v1) = B*(C*v1)
+44 : A*(C*(A*v1)) = C*v1
+45 : A*(C*A) = C
+129 : A*I(B) = I(B)*A
+130 : I(v1*v2) = I(v2)*I(v1)
+134 : A*(I(B)*v1) = I(B)*(A*v1)
+135 : C*I(B) = I(B)*C
+136 : C*(I(B)*v1) = I(B)*(C*v1)
diff --git a/test/Results/nucleic.out b/test/Results/nucleic.out
new file mode 100644
index 00000000..14689cdb
--- /dev/null
+++ b/test/Results/nucleic.out
@@ -0,0 +1 @@
+33.7976
diff --git a/test/Results/quicksort.fast.out b/test/Results/quicksort.fast.out
new file mode 100644
index 00000000..2c94e483
--- /dev/null
+++ b/test/Results/quicksort.fast.out
@@ -0,0 +1,2 @@
+OK
+OK
diff --git a/test/Results/quicksort.out b/test/Results/quicksort.out
new file mode 100644
index 00000000..2c94e483
--- /dev/null
+++ b/test/Results/quicksort.out
@@ -0,0 +1,2 @@
+OK
+OK
diff --git a/test/Results/sieve.out b/test/Results/sieve.out
new file mode 100644
index 00000000..8ca674d4
--- /dev/null
+++ b/test/Results/sieve.out
@@ -0,0 +1 @@
+2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 1009 1013 1019 1021 1031 1033 1039 1049 1051 1061 1063 1069 1087 1091 1093 1097 1103 1109 1117 1123 1129 1151 1153 1163 1171 1181 1187 1193 1201 1213 1217 1223 1229 1231 1237 1249 1259 1277 1279 1283 1289 1291 1297 1301 1303 1307 1319 1321 1327 1361 1367 1373 1381 1399 1409 1423 1427 1429 1433 1439 1447 1451 1453 1459 1471 1481 1483 1487 1489 1493 1499 1511 1523 1531 1543 1549 1553 1559 1567 1571 1579 1583 1597 1601 1607 1609 1613 1619 1621 1627 1637 1657 1663 1667 1669 1693 1697 1699 1709 1721 1723 1733 1741 1747 1753 1759 1777 1783 1787 1789 1801 1811 1823 1831 1847 1861 1867 1871 1873 1877 1879 1889 1901 1907 1913 1931 1933 1949 1951 1973 1979 1987 1993 1997 1999 2003 2011 2017 2027 2029 2039 2053 2063 2069 2081 2083 2087 2089 2099 2111 2113 2129 2131 2137 2141 2143 2153 2161 2179 2203 2207 2213 2221 2237 2239 2243 2251 2267 2269 2273 2281 2287 2293 2297 2309 2311 2333 2339 2341 2347 2351 2357 2371 2377 2381 2383 2389 2393 2399 2411 2417 2423 2437 2441 2447 2459 2467 2473 2477 2503 2521 2531 2539 2543 2549 2551 2557 2579 2591 2593 2609 2617 2621 2633 2647 2657 2659 2663 2671 2677 2683 2687 2689 2693 2699 2707 2711 2713 2719 2729 2731 2741 2749 2753 2767 2777 2789 2791 2797 2801 2803 2819 2833 2837 2843 2851 2857 2861 2879 2887 2897 2903 2909 2917 2927 2939 2953 2957 2963 2969 2971 2999 3001 3011 3019 3023 3037 3041 3049 3061 3067 3079 3083 3089 3109 3119 3121 3137 3163 3167 3169 3181 3187 3191 3203 3209 3217 3221 3229 3251 3253 3257 3259 3271 3299 3301 3307 3313 3319 3323 3329 3331 3343 3347 3359 3361 3371 3373 3389 3391 3407 3413 3433 3449 3457 3461 3463 3467 3469 3491 3499 3511 3517 3527 3529 3533 3539 3541 3547 3557 3559 3571 3581 3583 3593 3607 3613 3617 3623 3631 3637 3643 3659 3671 3673 3677 3691 3697 3701 3709 3719 3727 3733 3739 3761 3767 3769 3779 3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907 3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013 4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129 4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243 4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363 4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493 4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621 4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729 4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871 4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973 4987 4993 4999 5003 5009 5011 5021 5023 5039 5051 5059 5077 5081 5087 5099 5101 5107 5113 5119 5147 5153 5167 5171 5179 5189 5197 5209 5227 5231 5233 5237 5261 5273 5279 5281 5297 5303 5309 5323 5333 5347 5351 5381 5387 5393 5399 5407 5413 5417 5419 5431 5437 5441 5443 5449 5471 5477 5479 5483 5501 5503 5507 5519 5521 5527 5531 5557 5563 5569 5573 5581 5591 5623 5639 5641 5647 5651 5653 5657 5659 5669 5683 5689 5693 5701 5711 5717 5737 5741 5743 5749 5779 5783 5791 5801 5807 5813 5821 5827 5839 5843 5849 5851 5857 5861 5867 5869 5879 5881 5897 5903 5923 5927 5939 5953 5981 5987 6007 6011 6029 6037 6043 6047 6053 6067 6073 6079 6089 6091 6101 6113 6121 6131 6133 6143 6151 6163 6173 6197 6199 6203 6211 6217 6221 6229 6247 6257 6263 6269 6271 6277 6287 6299 6301 6311 6317 6323 6329 6337 6343 6353 6359 6361 6367 6373 6379 6389 6397 6421 6427 6449 6451 6469 6473 6481 6491 6521 6529 6547 6551 6553 6563 6569 6571 6577 6581 6599 6607 6619 6637 6653 6659 6661 6673 6679 6689 6691 6701 6703 6709 6719 6733 6737 6761 6763 6779 6781 6791 6793 6803 6823 6827 6829 6833 6841 6857 6863 6869 6871 6883 6899 6907 6911 6917 6947 6949 6959 6961 6967 6971 6977 6983 6991 6997 7001 7013 7019 7027 7039 7043 7057 7069 7079 7103 7109 7121 7127 7129 7151 7159 7177 7187 7193 7207 7211 7213 7219 7229 7237 7243 7247 7253 7283 7297 7307 7309 7321 7331 7333 7349 7351 7369 7393 7411 7417 7433 7451 7457 7459 7477 7481 7487 7489 7499 7507 7517 7523 7529 7537 7541 7547 7549 7559 7561 7573 7577 7583 7589 7591 7603 7607 7621 7639 7643 7649 7669 7673 7681 7687 7691 7699 7703 7717 7723 7727 7741 7753 7757 7759 7789 7793 7817 7823 7829 7841 7853 7867 7873 7877 7879 7883 7901 7907 7919 7927 7933 7937 7949 7951 7963 7993 8009 8011 8017 8039 8053 8059 8069 8081 8087 8089 8093 8101 8111 8117 8123 8147 8161 8167 8171 8179 8191 8209 8219 8221 8231 8233 8237 8243 8263 8269 8273 8287 8291 8293 8297 8311 8317 8329 8353 8363 8369 8377 8387 8389 8419 8423 8429 8431 8443 8447 8461 8467 8501 8513 8521 8527 8537 8539 8543 8563 8573 8581 8597 8599 8609 8623 8627 8629 8641 8647 8663 8669 8677 8681 8689 8693 8699 8707 8713 8719 8731 8737 8741 8747 8753 8761 8779 8783 8803 8807 8819 8821 8831 8837 8839 8849 8861 8863 8867 8887 8893 8923 8929 8933 8941 8951 8963 8969 8971 8999 9001 9007 9011 9013 9029 9041 9043 9049 9059 9067 9091 9103 9109 9127 9133 9137 9151 9157 9161 9173 9181 9187 9199 9203 9209 9221 9227 9239 9241 9257 9277 9281 9283 9293 9311 9319 9323 9337 9341 9343 9349 9371 9377 9391 9397 9403 9413 9419 9421 9431 9433 9437 9439 9461 9463 9467 9473 9479 9491 9497 9511 9521 9533 9539 9547 9551 9587 9601 9613 9619 9623 9629 9631 9643 9649 9661 9677 9679 9689 9697 9719 9721 9733 9739 9743 9749 9767 9769 9781 9787 9791 9803 9811 9817 9829 9833 9839 9851 9857 9859 9871 9883 9887 9901 9907 9923 9929 9931 9941 9949 9967 9973 10007 10009 10037 10039 10061 10067 10069 10079 10091 10093 10099 10103 10111 10133 10139 10141 10151 10159 10163 10169 10177 10181 10193 10211 10223 10243 10247 10253 10259 10267 10271 10273 10289 10301 10303 10313 10321 10331 10333 10337 10343 10357 10369 10391 10399 10427 10429 10433 10453 10457 10459 10463 10477 10487 10499 10501 10513 10529 10531 10559 10567 10589 10597 10601 10607 10613 10627 10631 10639 10651 10657 10663 10667 10687 10691 10709 10711 10723 10729 10733 10739 10753 10771 10781 10789 10799 10831 10837 10847 10853 10859 10861 10867 10883 10889 10891 10903 10909 10937 10939 10949 10957 10973 10979 10987 10993 11003 11027 11047 11057 11059 11069 11071 11083 11087 11093 11113 11117 11119 11131 11149 11159 11161 11171 11173 11177 11197 11213 11239 11243 11251 11257 11261 11273 11279 11287 11299 11311 11317 11321 11329 11351 11353 11369 11383 11393 11399 11411 11423 11437 11443 11447 11467 11471 11483 11489 11491 11497 11503 11519 11527 11549 11551 11579 11587 11593 11597 11617 11621 11633 11657 11677 11681 11689 11699 11701 11717 11719 11731 11743 11777 11779 11783 11789 11801 11807 11813 11821 11827 11831 11833 11839 11863 11867 11887 11897 11903 11909 11923 11927 11933 11939 11941 11953 11959 11969 11971 11981 11987 12007 12011 12037 12041 12043 12049 12071 12073 12097 12101 12107 12109 12113 12119 12143 12149 12157 12161 12163 12197 12203 12211 12227 12239 12241 12251 12253 12263 12269 12277 12281 12289 12301 12323 12329 12343 12347 12373 12377 12379 12391 12401 12409 12413 12421 12433 12437 12451 12457 12473 12479 12487 12491 12497 12503 12511 12517 12527 12539 12541 12547 12553 12569 12577 12583 12589 12601 12611 12613 12619 12637 12641 12647 12653 12659 12671 12689 12697 12703 12713 12721 12739 12743 12757 12763 12781 12791 12799 12809 12821 12823 12829 12841 12853 12889 12893 12899 12907 12911 12917 12919 12923 12941 12953 12959 12967 12973 12979 12983 13001 13003 13007 13009 13033 13037 13043 13049 13063 13093 13099 13103 13109 13121 13127 13147 13151 13159 13163 13171 13177 13183 13187 13217 13219 13229 13241 13249 13259 13267 13291 13297 13309 13313 13327 13331 13337 13339 13367 13381 13397 13399 13411 13417 13421 13441 13451 13457 13463 13469 13477 13487 13499 13513 13523 13537 13553 13567 13577 13591 13597 13613 13619 13627 13633 13649 13669 13679 13681 13687 13691 13693 13697 13709 13711 13721 13723 13729 13751 13757 13759 13763 13781 13789 13799 13807 13829 13831 13841 13859 13873 13877 13879 13883 13901 13903 13907 13913 13921 13931 13933 13963 13967 13997 13999 14009 14011 14029 14033 14051 14057 14071 14081 14083 14087 14107 14143 14149 14153 14159 14173 14177 14197 14207 14221 14243 14249 14251 14281 14293 14303 14321 14323 14327 14341 14347 14369 14387 14389 14401 14407 14411 14419 14423 14431 14437 14447 14449 14461 14479 14489 14503 14519 14533 14537 14543 14549 14551 14557 14561 14563 14591 14593 14621 14627 14629 14633 14639 14653 14657 14669 14683 14699 14713 14717 14723 14731 14737 14741 14747 14753 14759 14767 14771 14779 14783 14797 14813 14821 14827 14831 14843 14851 14867 14869 14879 14887 14891 14897 14923 14929 14939 14947 14951 14957 14969 14983 15013 15017 15031 15053 15061 15073 15077 15083 15091 15101 15107 15121 15131 15137 15139 15149 15161 15173 15187 15193 15199 15217 15227 15233 15241 15259 15263 15269 15271 15277 15287 15289 15299 15307 15313 15319 15329 15331 15349 15359 15361 15373 15377 15383 15391 15401 15413 15427 15439 15443 15451 15461 15467 15473 15493 15497 15511 15527 15541 15551 15559 15569 15581 15583 15601 15607 15619 15629 15641 15643 15647 15649 15661 15667 15671 15679 15683 15727 15731 15733 15737 15739 15749 15761 15767 15773 15787 15791 15797 15803 15809 15817 15823 15859 15877 15881 15887 15889 15901 15907 15913 15919 15923 15937 15959 15971 15973 15991 16001 16007 16033 16057 16061 16063 16067 16069 16073 16087 16091 16097 16103 16111 16127 16139 16141 16183 16187 16189 16193 16217 16223 16229 16231 16249 16253 16267 16273 16301 16319 16333 16339 16349 16361 16363 16369 16381 16411 16417 16421 16427 16433 16447 16451 16453 16477 16481 16487 16493 16519 16529 16547 16553 16561 16567 16573 16603 16607 16619 16631 16633 16649 16651 16657 16661 16673 16691 16693 16699 16703 16729 16741 16747 16759 16763 16787 16811 16823 16829 16831 16843 16871 16879 16883 16889 16901 16903 16921 16927 16931 16937 16943 16963 16979 16981 16987 16993 17011 17021 17027 17029 17033 17041 17047 17053 17077 17093 17099 17107 17117 17123 17137 17159 17167 17183 17189 17191 17203 17207 17209 17231 17239 17257 17291 17293 17299 17317 17321 17327 17333 17341 17351 17359 17377 17383 17387 17389 17393 17401 17417 17419 17431 17443 17449 17467 17471 17477 17483 17489 17491 17497 17509 17519 17539 17551 17569 17573 17579 17581 17597 17599 17609 17623 17627 17657 17659 17669 17681 17683 17707 17713 17729 17737 17747 17749 17761 17783 17789 17791 17807 17827 17837 17839 17851 17863 17881 17891 17903 17909 17911 17921 17923 17929 17939 17957 17959 17971 17977 17981 17987 17989 18013 18041 18043 18047 18049 18059 18061 18077 18089 18097 18119 18121 18127 18131 18133 18143 18149 18169 18181 18191 18199 18211 18217 18223 18229 18233 18251 18253 18257 18269 18287 18289 18301 18307 18311 18313 18329 18341 18353 18367 18371 18379 18397 18401 18413 18427 18433 18439 18443 18451 18457 18461 18481 18493 18503 18517 18521 18523 18539 18541 18553 18583 18587 18593 18617 18637 18661 18671 18679 18691 18701 18713 18719 18731 18743 18749 18757 18773 18787 18793 18797 18803 18839 18859 18869 18899 18911 18913 18917 18919 18947 18959 18973 18979 19001 19009 19013 19031 19037 19051 19069 19073 19079 19081 19087 19121 19139 19141 19157 19163 19181 19183 19207 19211 19213 19219 19231 19237 19249 19259 19267 19273 19289 19301 19309 19319 19333 19373 19379 19381 19387 19391 19403 19417 19421 19423 19427 19429 19433 19441 19447 19457 19463 19469 19471 19477 19483 19489 19501 19507 19531 19541 19543 19553 19559 19571 19577 19583 19597 19603 19609 19661 19681 19687 19697 19699 19709 19717 19727 19739 19751 19753 19759 19763 19777 19793 19801 19813 19819 19841 19843 19853 19861 19867 19889 19891 19913 19919 19927 19937 19949 19961 19963 19973 19979 19991 19993 19997 20011 20021 20023 20029 20047 20051 20063 20071 20089 20101 20107 20113 20117 20123 20129 20143 20147 20149 20161 20173 20177 20183 20201 20219 20231 20233 20249 20261 20269 20287 20297 20323 20327 20333 20341 20347 20353 20357 20359 20369 20389 20393 20399 20407 20411 20431 20441 20443 20477 20479 20483 20507 20509 20521 20533 20543 20549 20551 20563 20593 20599 20611 20627 20639 20641 20663 20681 20693 20707 20717 20719 20731 20743 20747 20749 20753 20759 20771 20773 20789 20807 20809 20849 20857 20873 20879 20887 20897 20899 20903 20921 20929 20939 20947 20959 20963 20981 20983 21001 21011 21013 21017 21019 21023 21031 21059 21061 21067 21089 21101 21107 21121 21139 21143 21149 21157 21163 21169 21179 21187 21191 21193 21211 21221 21227 21247 21269 21277 21283 21313 21317 21319 21323 21341 21347 21377 21379 21383 21391 21397 21401 21407 21419 21433 21467 21481 21487 21491 21493 21499 21503 21517 21521 21523 21529 21557 21559 21563 21569 21577 21587 21589 21599 21601 21611 21613 21617 21647 21649 21661 21673 21683 21701 21713 21727 21737 21739 21751 21757 21767 21773 21787 21799 21803 21817 21821 21839 21841 21851 21859 21863 21871 21881 21893 21911 21929 21937 21943 21961 21977 21991 21997 22003 22013 22027 22031 22037 22039 22051 22063 22067 22073 22079 22091 22093 22109 22111 22123 22129 22133 22147 22153 22157 22159 22171 22189 22193 22229 22247 22259 22271 22273 22277 22279 22283 22291 22303 22307 22343 22349 22367 22369 22381 22391 22397 22409 22433 22441 22447 22453 22469 22481 22483 22501 22511 22531 22541 22543 22549 22567 22571 22573 22613 22619 22621 22637 22639 22643 22651 22669 22679 22691 22697 22699 22709 22717 22721 22727 22739 22741 22751 22769 22777 22783 22787 22807 22811 22817 22853 22859 22861 22871 22877 22901 22907 22921 22937 22943 22961 22963 22973 22993 23003 23011 23017 23021 23027 23029 23039 23041 23053 23057 23059 23063 23071 23081 23087 23099 23117 23131 23143 23159 23167 23173 23189 23197 23201 23203 23209 23227 23251 23269 23279 23291 23293 23297 23311 23321 23327 23333 23339 23357 23369 23371 23399 23417 23431 23447 23459 23473 23497 23509 23531 23537 23539 23549 23557 23561 23563 23567 23581 23593 23599 23603 23609 23623 23627 23629 23633 23663 23669 23671 23677 23687 23689 23719 23741 23743 23747 23753 23761 23767 23773 23789 23801 23813 23819 23827 23831 23833 23857 23869 23873 23879 23887 23893 23899 23909 23911 23917 23929 23957 23971 23977 23981 23993 24001 24007 24019 24023 24029 24043 24049 24061 24071 24077 24083 24091 24097 24103 24107 24109 24113 24121 24133 24137 24151 24169 24179 24181 24197 24203 24223 24229 24239 24247 24251 24281 24317 24329 24337 24359 24371 24373 24379 24391 24407 24413 24419 24421 24439 24443 24469 24473 24481 24499 24509 24517 24527 24533 24547 24551 24571 24593 24611 24623 24631 24659 24671 24677 24683 24691 24697 24709 24733 24749 24763 24767 24781 24793 24799 24809 24821 24841 24847 24851 24859 24877 24889 24907 24917 24919 24923 24943 24953 24967 24971 24977 24979 24989 25013 25031 25033 25037 25057 25073 25087 25097 25111 25117 25121 25127 25147 25153 25163 25169 25171 25183 25189 25219 25229 25237 25243 25247 25253 25261 25301 25303 25307 25309 25321 25339 25343 25349 25357 25367 25373 25391 25409 25411 25423 25439 25447 25453 25457 25463 25469 25471 25523 25537 25541 25561 25577 25579 25583 25589 25601 25603 25609 25621 25633 25639 25643 25657 25667 25673 25679 25693 25703 25717 25733 25741 25747 25759 25763 25771 25793 25799 25801 25819 25841 25847 25849 25867 25873 25889 25903 25913 25919 25931 25933 25939 25943 25951 25969 25981 25997 25999 26003 26017 26021 26029 26041 26053 26083 26099 26107 26111 26113 26119 26141 26153 26161 26171 26177 26183 26189 26203 26209 26227 26237 26249 26251 26261 26263 26267 26293 26297 26309 26317 26321 26339 26347 26357 26371 26387 26393 26399 26407 26417 26423 26431 26437 26449 26459 26479 26489 26497 26501 26513 26539 26557 26561 26573 26591 26597 26627 26633 26641 26647 26669 26681 26683 26687 26693 26699 26701 26711 26713 26717 26723 26729 26731 26737 26759 26777 26783 26801 26813 26821 26833 26839 26849 26861 26863 26879 26881 26891 26893 26903 26921 26927 26947 26951 26953 26959 26981 26987 26993 27011 27017 27031 27043 27059 27061 27067 27073 27077 27091 27103 27107 27109 27127 27143 27179 27191 27197 27211 27239 27241 27253 27259 27271 27277 27281 27283 27299 27329 27337 27361 27367 27397 27407 27409 27427 27431 27437 27449 27457 27479 27481 27487 27509 27527 27529 27539 27541 27551 27581 27583 27611 27617 27631 27647 27653 27673 27689 27691 27697 27701 27733 27737 27739 27743 27749 27751 27763 27767 27773 27779 27791 27793 27799 27803 27809 27817 27823 27827 27847 27851 27883 27893 27901 27917 27919 27941 27943 27947 27953 27961 27967 27983 27997 28001 28019 28027 28031 28051 28057 28069 28081 28087 28097 28099 28109 28111 28123 28151 28163 28181 28183 28201 28211 28219 28229 28277 28279 28283 28289 28297 28307 28309 28319 28349 28351 28387 28393 28403 28409 28411 28429 28433 28439 28447 28463 28477 28493 28499 28513 28517 28537 28541 28547 28549 28559 28571 28573 28579 28591 28597 28603 28607 28619 28621 28627 28631 28643 28649 28657 28661 28663 28669 28687 28697 28703 28711 28723 28729 28751 28753 28759 28771 28789 28793 28807 28813 28817 28837 28843 28859 28867 28871 28879 28901 28909 28921 28927 28933 28949 28961 28979 29009 29017 29021 29023 29027 29033 29059 29063 29077 29101 29123 29129 29131 29137 29147 29153 29167 29173 29179 29191 29201 29207 29209 29221 29231 29243 29251 29269 29287 29297 29303 29311 29327 29333 29339 29347 29363 29383 29387 29389 29399 29401 29411 29423 29429 29437 29443 29453 29473 29483 29501 29527 29531 29537 29567 29569 29573 29581 29587 29599 29611 29629 29633 29641 29663 29669 29671 29683 29717 29723 29741 29753 29759 29761 29789 29803 29819 29833 29837 29851 29863 29867 29873 29879 29881 29917 29921 29927 29947 29959 29983 29989 30011 30013 30029 30047 30059 30071 30089 30091 30097 30103 30109 30113 30119 30133 30137 30139 30161 30169 30181 30187 30197 30203 30211 30223 30241 30253 30259 30269 30271 30293 30307 30313 30319 30323 30341 30347 30367 30389 30391 30403 30427 30431 30449 30467 30469 30491 30493 30497 30509 30517 30529 30539 30553 30557 30559 30577 30593 30631 30637 30643 30649 30661 30671 30677 30689 30697 30703 30707 30713 30727 30757 30763 30773 30781 30803 30809 30817 30829 30839 30841 30851 30853 30859 30869 30871 30881 30893 30911 30931 30937 30941 30949 30971 30977 30983 31013 31019 31033 31039 31051 31063 31069 31079 31081 31091 31121 31123 31139 31147 31151 31153 31159 31177 31181 31183 31189 31193 31219 31223 31231 31237 31247 31249 31253 31259 31267 31271 31277 31307 31319 31321 31327 31333 31337 31357 31379 31387 31391 31393 31397 31469 31477 31481 31489 31511 31513 31517 31531 31541 31543 31547 31567 31573 31583 31601 31607 31627 31643 31649 31657 31663 31667 31687 31699 31721 31723 31727 31729 31741 31751 31769 31771 31793 31799 31817 31847 31849 31859 31873 31883 31891 31907 31957 31963 31973 31981 31991 32003 32009 32027 32029 32051 32057 32059 32063 32069 32077 32083 32089 32099 32117 32119 32141 32143 32159 32173 32183 32189 32191 32203 32213 32233 32237 32251 32257 32261 32297 32299 32303 32309 32321 32323 32327 32341 32353 32359 32363 32369 32371 32377 32381 32401 32411 32413 32423 32429 32441 32443 32467 32479 32491 32497 32503 32507 32531 32533 32537 32561 32563 32569 32573 32579 32587 32603 32609 32611 32621 32633 32647 32653 32687 32693 32707 32713 32717 32719 32749 32771 32779 32783 32789 32797 32801 32803 32831 32833 32839 32843 32869 32887 32909 32911 32917 32933 32939 32941 32957 32969 32971 32983 32987 32993 32999 33013 33023 33029 33037 33049 33053 33071 33073 33083 33091 33107 33113 33119 33149 33151 33161 33179 33181 33191 33199 33203 33211 33223 33247 33287 33289 33301 33311 33317 33329 33331 33343 33347 33349 33353 33359 33377 33391 33403 33409 33413 33427 33457 33461 33469 33479 33487 33493 33503 33521 33529 33533 33547 33563 33569 33577 33581 33587 33589 33599 33601 33613 33617 33619 33623 33629 33637 33641 33647 33679 33703 33713 33721 33739 33749 33751 33757 33767 33769 33773 33791 33797 33809 33811 33827 33829 33851 33857 33863 33871 33889 33893 33911 33923 33931 33937 33941 33961 33967 33997 34019 34031 34033 34039 34057 34061 34123 34127 34129 34141 34147 34157 34159 34171 34183 34211 34213 34217 34231 34253 34259 34261 34267 34273 34283 34297 34301 34303 34313 34319 34327 34337 34351 34361 34367 34369 34381 34403 34421 34429 34439 34457 34469 34471 34483 34487 34499 34501 34511 34513 34519 34537 34543 34549 34583 34589 34591 34603 34607 34613 34631 34649 34651 34667 34673 34679 34687 34693 34703 34721 34729 34739 34747 34757 34759 34763 34781 34807 34819 34841 34843 34847 34849 34871 34877 34883 34897 34913 34919 34939 34949 34961 34963 34981 35023 35027 35051 35053 35059 35069 35081 35083 35089 35099 35107 35111 35117 35129 35141 35149 35153 35159 35171 35201 35221 35227 35251 35257 35267 35279 35281 35291 35311 35317 35323 35327 35339 35353 35363 35381 35393 35401 35407 35419 35423 35437 35447 35449 35461 35491 35507 35509 35521 35527 35531 35533 35537 35543 35569 35573 35591 35593 35597 35603 35617 35671 35677 35729 35731 35747 35753 35759 35771 35797 35801 35803 35809 35831 35837 35839 35851 35863 35869 35879 35897 35899 35911 35923 35933 35951 35963 35969 35977 35983 35993 35999 36007 36011 36013 36017 36037 36061 36067 36073 36083 36097 36107 36109 36131 36137 36151 36161 36187 36191 36209 36217 36229 36241 36251 36263 36269 36277 36293 36299 36307 36313 36319 36341 36343 36353 36373 36383 36389 36433 36451 36457 36467 36469 36473 36479 36493 36497 36523 36527 36529 36541 36551 36559 36563 36571 36583 36587 36599 36607 36629 36637 36643 36653 36671 36677 36683 36691 36697 36709 36713 36721 36739 36749 36761 36767 36779 36781 36787 36791 36793 36809 36821 36833 36847 36857 36871 36877 36887 36899 36901 36913 36919 36923 36929 36931 36943 36947 36973 36979 36997 37003 37013 37019 37021 37039 37049 37057 37061 37087 37097 37117 37123 37139 37159 37171 37181 37189 37199 37201 37217 37223 37243 37253 37273 37277 37307 37309 37313 37321 37337 37339 37357 37361 37363 37369 37379 37397 37409 37423 37441 37447 37463 37483 37489 37493 37501 37507 37511 37517 37529 37537 37547 37549 37561 37567 37571 37573 37579 37589 37591 37607 37619 37633 37643 37649 37657 37663 37691 37693 37699 37717 37747 37781 37783 37799 37811 37813 37831 37847 37853 37861 37871 37879 37889 37897 37907 37951 37957 37963 37967 37987 37991 37993 37997 38011 38039 38047 38053 38069 38083 38113 38119 38149 38153 38167 38177 38183 38189 38197 38201 38219 38231 38237 38239 38261 38273 38281 38287 38299 38303 38317 38321 38327 38329 38333 38351 38371 38377 38393 38431 38447 38449 38453 38459 38461 38501 38543 38557 38561 38567 38569 38593 38603 38609 38611 38629 38639 38651 38653 38669 38671 38677 38693 38699 38707 38711 38713 38723 38729 38737 38747 38749 38767 38783 38791 38803 38821 38833 38839 38851 38861 38867 38873 38891 38903 38917 38921 38923 38933 38953 38959 38971 38977 38993 39019 39023 39041 39043 39047 39079 39089 39097 39103 39107 39113 39119 39133 39139 39157 39161 39163 39181 39191 39199 39209 39217 39227 39229 39233 39239 39241 39251 39293 39301 39313 39317 39323 39341 39343 39359 39367 39371 39373 39383 39397 39409 39419 39439 39443 39451 39461 39499 39503 39509 39511 39521 39541 39551 39563 39569 39581 39607 39619 39623 39631 39659 39667 39671 39679 39703 39709 39719 39727 39733 39749 39761 39769 39779 39791 39799 39821 39827 39829 39839 39841 39847 39857 39863 39869 39877 39883 39887 39901 39929 39937 39953 39971 39979 39983 39989 
diff --git a/test/Results/soli.fast.out b/test/Results/soli.fast.out
new file mode 100644
index 00000000..b94045c3
--- /dev/null
+++ b/test/Results/soli.fast.out
@@ -0,0 +1,50 @@
+500
+1000
+1500
+2000
+2500
+3000
+3500
+4000
+4500
+5000
+5500
+6000
+6500
+7000
+7500
+8000
+8500
+9000
+9500
+10000
+10500
+11000
+11500
+12000
+12500
+13000
+13500
+14000
+14500
+15000
+15500
+16000
+16500
+17000
+17500
+18000
+18500
+19000
+19500
+20000
+
+.........
+...   ...
+...   ...
+.       .
+.   $   .
+.       .
+...   ...
+...   ...
+.........
diff --git a/test/Results/soli.out b/test/Results/soli.out
new file mode 100644
index 00000000..b94045c3
--- /dev/null
+++ b/test/Results/soli.out
@@ -0,0 +1,50 @@
+500
+1000
+1500
+2000
+2500
+3000
+3500
+4000
+4500
+5000
+5500
+6000
+6500
+7000
+7500
+8000
+8500
+9000
+9500
+10000
+10500
+11000
+11500
+12000
+12500
+13000
+13500
+14000
+14500
+15000
+15500
+16000
+16500
+17000
+17500
+18000
+18500
+19000
+19500
+20000
+
+.........
+...   ...
+...   ...
+.       .
+.   $   .
+.       .
+...   ...
+...   ...
+.........
diff --git a/test/Results/sorts.out b/test/Results/sorts.out
new file mode 100644
index 00000000..fa0cc048
--- /dev/null
+++ b/test/Results/sorts.out
@@ -0,0 +1,198 @@
+Command line arguments are:
+Testing List.sort...
+  List.sort with constant ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.sort with sorted ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.sort with reverse-sorted ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.sort with random ints (many dups)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.sort with random ints (few dups)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.sort with records (str)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.sort with records (int[1])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.sort with records (int[10])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.sort with records (int[100])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.sort with records (int[1000])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+Testing List.stable_sort...
+  List.stable_sort with constant ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with sorted ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with reverse-sorted ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with random ints (many dups)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with random ints (few dups)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with records (str)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with records (int[1])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with records (int[10])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with records (int[100])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with records (int[1000])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with records (int[1]) [stable]
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with records (int[10]) [stable]
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with records (int[100]) [stable]
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  List.stable_sort with records (int[1000]) [stable]
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+Testing Array.sort...
+  Array.sort with constant ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.sort with sorted ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.sort with reverse-sorted ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.sort with random ints (many dups)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.sort with random ints (few dups)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.sort with records (str)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.sort with records (int[1])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.sort with records (int[10])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.sort with records (int[100])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.sort with records (int[1000])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+Testing Array.stable_sort...
+  Array.stable_sort with constant ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with sorted ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with reverse-sorted ints
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with random ints (many dups)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with random ints (few dups)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with records (str)
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with records (int[1])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with records (int[10])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with records (int[100])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with records (int[1000])
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with records (int[1]) [stable]
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with records (int[10]) [stable]
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with records (int[100]) [stable]
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+  Array.stable_sort with records (int[1000]) [stable]
+        0.    1.    2.    3.    4.    5.    6.    7.    8.    9.   10.   11.
+       12.   13.   28.  100.  127.  128.  129.  191.  192.  193.  506. 1000.
+     1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123.
+Number of tests failed: 0
diff --git a/test/Results/takc.out b/test/Results/takc.out
new file mode 100644
index 00000000..0fecf653
--- /dev/null
+++ b/test/Results/takc.out
@@ -0,0 +1 @@
+350
diff --git a/test/Results/taku.out b/test/Results/taku.out
new file mode 100644
index 00000000..0fecf653
--- /dev/null
+++ b/test/Results/taku.out
@@ -0,0 +1 @@
+350
diff --git a/test/alloc.ml b/test/alloc.ml
new file mode 100644
index 00000000..51de6c5a
--- /dev/null
+++ b/test/alloc.ml
@@ -0,0 +1,51 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: alloc.ml,v 1.2 1999/11/17 18:58:33 xleroy Exp $ *)
+
+(* Random allocation test *)
+
+(*
+  Allocate arrays of strings, of random sizes in [0..1000[, and put them
+  into an array of 32768.  Replace a randomly-selected array with a new
+  random-length array.  Reiterate ad infinitum.
+*)
+
+let l = 32768;;
+let m = 1000;;
+
+let ar = Array.create l "";;
+
+Random.init 1234;;
+
+let compact_flag = ref false;;
+
+let main () =
+  while true do
+    for i = 1 to 100000 do
+      ar.(Random.int l) <- String.create (Random.int m);
+    done;
+    if !compact_flag then Gc.compact () else Gc.full_major ();
+    print_newline ();
+    Gc.print_stat stdout;
+    flush stdout;
+  done
+;;
+
+let argspecs = [
+  "-c", Arg.Set compact_flag, "do heap compactions";
+];;
+
+Arg.parse argspecs (fun _ -> ()) "Usage: alloc [-c]";;
+
+main ();;
+
diff --git a/test/almabench.ml b/test/almabench.ml
new file mode 100644
index 00000000..f1dd10c9
--- /dev/null
+++ b/test/almabench.ml
@@ -0,0 +1,324 @@
+(*
+ * ALMABENCH 1.0.1
+ * Objective Caml version
+ *
+ *     A number-crunching benchmark designed for cross-language and vendor
+ *     comparisons.
+ *
+ *     Written by Shawn Wagner, from Scott Robert Ladd's versions for
+ *      C++ and java.
+ *
+ *     No rights reserved. This is public domain software, for use by anyone.
+ *
+ *     This program calculates the daily ephemeris (at noon) for the years
+ *     2000-2099 using an algorithm developed by J.L. Simon, P. Bretagnon, J.
+ *     Chapront, M. Chapront-Touze, G. Francou and J. Laskar of the Bureau des
+ *     Longitudes, Paris, France), as detailed in Astronomy & Astrophysics
+ *     282, 663 (1994)
+ *
+ *    Note that the code herein is design for the purpose of testing 
+ *     computational performance; error handling and other such "niceties"
+ *    is virtually non-existent.
+ *
+ *    Actual (and oft-updated) benchmark results can be found at:
+ *            http://www.coyotegulch.com
+ *
+ *    Please do not use this information or algorithm in any way that might
+ *    upset the balance of the universe or otherwise cause planets to impact
+ *    upon one another.
+ *)
+
+let pic = 3.14159265358979323846
+and j2000     = 2451545.0
+and jcentury  = 36525.0
+and jmillenia = 365250.0
+
+let twopi     = 2.0 *. pic
+and a2r       = pic /. 648000.0
+and r2h       = 12.0 /. pic
+and r2d       = 180.0 /. pic
+and gaussk    = 0.01720209895
+
+(* number of days to include in test *)
+let test_loops  = 5  (* was: 20 *)
+and test_length = 36525
+
+(* sin and cos of j2000 mean obliquity (iau 1976) *)
+and sineps = 0.3977771559319137
+and coseps = 0.9174820620691818
+
+and amas = [|  6023600.0; 408523.5; 328900.5; 3098710.0; 1047.355; 3498.5; 22869.0; 19314.0 |]
+
+(*
+ * tables giving the mean keplerian elements, limited to t**2 terms:
+ *        a       semi-major axis (au)
+ *        dlm     mean longitude (degree and arcsecond)
+ *        e       eccentricity
+ *        pi      longitude of the perihelion (degree and arcsecond)
+ *        dinc    inclination (degree and arcsecond)
+ *        omega   longitude of the ascending node (degree and arcsecond)
+ *)
+and a = [|
+  [|   0.3870983098;             0.0;        0.0 |];
+  [|   0.7233298200;             0.0;        0.0 |];
+  [|   1.0000010178;             0.0;        0.0 |];
+  [|   1.5236793419;         3e-10;        0.0 |];
+  [|   5.2026032092;     19132e-10;  -39e-10 |];
+  [|   9.5549091915; -0.0000213896;  444e-10 |];
+  [|  19.2184460618;     -3716e-10;  979e-10 |];
+  [|  30.1103868694;    -16635e-10;  686e-10 |] |]
+
+and dlm =        
+  [| [| 252.25090552; 5381016286.88982;  -1.92789 |];
+     [| 181.97980085; 2106641364.33548;   0.59381 |];
+     [| 100.46645683; 1295977422.83429;  -2.04411 |];
+     [| 355.43299958;  689050774.93988;   0.94264 |];
+     [|  34.35151874;  109256603.77991; -30.60378 |];
+     [|  50.07744430;   43996098.55732;  75.61614 |];
+     [| 314.05500511;   15424811.93933;  -1.75083 |];
+     [| 304.34866548;    7865503.20744;   0.21103 |] |]
+
+and e =
+  [| [|   0.2056317526;  0.0002040653;    -28349e-10 |];
+     [|   0.0067719164; -0.0004776521;     98127e-10 |];
+     [|   0.0167086342; -0.0004203654; -0.0000126734 |];
+     [|   0.0934006477;  0.0009048438;    -80641e-10 |];
+     [|   0.0484979255;  0.0016322542; -0.0000471366 |];
+     [|   0.0555481426; -0.0034664062; -0.0000643639 |];
+     [|   0.0463812221; -0.0002729293;  0.0000078913 |];
+     [|   0.0094557470;  0.0000603263;           0.0 |] |]
+
+and pi =
+  [| [|  77.45611904;  5719.11590;   -4.83016 |];
+     [| 131.56370300;   175.48640; -498.48184 |];
+     [| 102.93734808; 11612.35290;   53.27577 |];
+     [| 336.06023395; 15980.45908;  -62.32800 |];
+     [|  14.33120687;  7758.75163;  259.95938 |];
+     [|  93.05723748; 20395.49439;  190.25952 |];
+     [| 173.00529106;  3215.56238;  -34.09288 |];
+     [|  48.12027554;  1050.71912;   27.39717 |] |]
+and dinc =
+  [| [|   7.00498625; -214.25629;   0.28977 |];
+     [|   3.39466189;  -30.84437; -11.67836 |];
+     [|          0.0;  469.97289;  -3.35053 |];
+     [|   1.84972648; -293.31722;  -8.11830 |];
+     [|   1.30326698;  -71.55890;  11.95297 |];
+     [|   2.48887878;   91.85195; -17.66225 |];
+     [|   0.77319689;  -60.72723;   1.25759 |];
+     [|   1.76995259;    8.12333;   0.08135 |] |]
+
+and omega =
+  [| [|  48.33089304;  -4515.21727;  -31.79892 |];
+     [|  76.67992019; -10008.48154;  -51.32614 |];
+     [| 174.87317577;  -8679.27034;   15.34191 |];
+     [|  49.55809321; -10620.90088; -230.57416 |];
+     [| 100.46440702;   6362.03561;  326.52178 |];
+     [| 113.66550252;  -9240.19942;  -66.23743 |];
+     [|  74.00595701;   2669.15033;  145.93964 |];
+     [| 131.78405702;   -221.94322;   -0.78728 |] |]
+
+(* tables for trigonometric terms to be added to the mean elements
+   of the semi-major axes. *)
+and kp =
+  [| [| 69613.0;  75645.0; 88306.0; 59899.0; 15746.0; 71087.0; 142173.0;  3086.0;    0.0 |];
+     [| 21863.0;  32794.0; 26934.0; 10931.0; 26250.0; 43725.0;  53867.0; 28939.0;    0.0 |];
+     [| 16002.0;  21863.0; 32004.0; 10931.0; 14529.0; 16368.0;  15318.0; 32794.0;    0.0 |];
+     [|  6345.0;   7818.0; 15636.0;  7077.0;  8184.0; 14163.0;   1107.0;  4872.0;    0.0 |];
+     [|  1760.0;   1454.0;  1167.0;   880.0;   287.0;  2640.0;     19.0;  2047.0; 1454.0 |];
+     [|   574.0;      0.0;   880.0;   287.0;    19.0;  1760.0;   1167.0;   306.0;  574.0 |];
+     [|   204.0;      0.0;   177.0;  1265.0;     4.0;   385.0;    200.0;   208.0;  204.0 |];
+     [|     0.0;    102.0;   106.0;     4.0;    98.0;  1367.0;    487.0;   204.0;    0.0 |] |]
+
+and ca =
+  [| [|       4.0;    -13.0;    11.0;    -9.0;    -9.0;    -3.0;    -1.0;     4.0;    0.0 |];
+     [|    -156.0;     59.0;   -42.0;     6.0;    19.0;   -20.0;   -10.0;   -12.0;    0.0 |];
+     [|      64.0;   -152.0;    62.0;    -8.0;    32.0;   -41.0;    19.0;   -11.0;    0.0 |];
+     [|     124.0;    621.0;  -145.0;   208.0;    54.0;   -57.0;    30.0;    15.0;    0.0 |];
+     [|  -23437.0;  -2634.0;  6601.0;  6259.0; -1507.0; -1821.0;  2620.0; -2115.0;-1489.0 |];
+     [|   62911.0;-119919.0; 79336.0; 17814.0;-24241.0; 12068.0;  8306.0; -4893.0; 8902.0 |];
+     [|  389061.0;-262125.0;-44088.0;  8387.0;-22976.0; -2093.0;  -615.0; -9720.0; 6633.0 |];
+     [| -412235.0;-157046.0;-31430.0; 37817.0; -9740.0;   -13.0; -7449.0;  9644.0;    0.0 |] |]
+
+and sa =
+  [| [|     -29.0;    -1.0;     9.0;     6.0;    -6.0;     5.0;     4.0;     0.0;    0.0 |];
+     [|     -48.0;  -125.0;   -26.0;   -37.0;    18.0;   -13.0;   -20.0;    -2.0;    0.0 |];
+     [|    -150.0;   -46.0;    68.0;    54.0;    14.0;    24.0;   -28.0;    22.0;    0.0 |];
+     [|    -621.0;   532.0;  -694.0;   -20.0;   192.0;   -94.0;    71.0;   -73.0;    0.0 |];
+     [|  -14614.0;-19828.0; -5869.0;  1881.0; -4372.0; -2255.0;   782.0;   930.0;  913.0 |];
+     [|  139737.0;     0.0; 24667.0; 51123.0; -5102.0;  7429.0; -4095.0; -1976.0;-9566.0 |];
+     [| -138081.0;     0.0; 37205.0;-49039.0;-41901.0;-33872.0;-27037.0;-12474.0;18797.0 |];
+     [|       0.0; 28492.0;133236.0; 69654.0; 52322.0;-49577.0;-26430.0; -3593.0;    0.0 |] |]
+
+(* tables giving the trigonometric terms to be added to the mean elements of
+   the mean longitudes . *)
+and kq = 
+  [| [|  3086.0; 15746.0; 69613.0; 59899.0; 75645.0; 88306.0; 12661.0; 2658.0;  0.0;   0.0 |];
+     [| 21863.0; 32794.0; 10931.0;    73.0;  4387.0; 26934.0;  1473.0; 2157.0;  0.0;   0.0 |];
+     [|    10.0; 16002.0; 21863.0; 10931.0;  1473.0; 32004.0;  4387.0;   73.0;  0.0;   0.0 |];
+     [|    10.0;  6345.0;  7818.0;  1107.0; 15636.0;  7077.0;  8184.0;  532.0; 10.0;   0.0 |];
+     [|    19.0;  1760.0;  1454.0;   287.0;  1167.0;   880.0;   574.0; 2640.0; 19.0;1454.0 |];
+     [|    19.0;   574.0;   287.0;   306.0;  1760.0;    12.0;    31.0;   38.0; 19.0; 574.0 |];
+     [|     4.0;   204.0;   177.0;     8.0;    31.0;   200.0;  1265.0;  102.0;  4.0; 204.0 |];
+     [|     4.0;   102.0;   106.0;     8.0;    98.0;  1367.0;   487.0;  204.0;  4.0; 102.0 |] |]
+
+and cl =
+  [| [|      21.0;   -95.0; -157.0;   41.0;   -5.0;   42.0;   23.0;   30.0;     0.0;    0.0 |];
+     [|    -160.0;  -313.0; -235.0;   60.0;  -74.0;  -76.0;  -27.0;   34.0;     0.0;    0.0 |];
+     [|    -325.0;  -322.0;  -79.0;  232.0;  -52.0;   97.0;   55.0;  -41.0;     0.0;    0.0 |];
+     [|    2268.0;  -979.0;  802.0;  602.0; -668.0;  -33.0;  345.0;  201.0;   -55.0;    0.0 |];
+     [|    7610.0; -4997.0;-7689.0;-5841.0;-2617.0; 1115.0; -748.0; -607.0;  6074.0;  354.0 |];
+     [|  -18549.0; 30125.0;20012.0; -730.0;  824.0;   23.0; 1289.0; -352.0;-14767.0;-2062.0 |];
+     [| -135245.0;-14594.0; 4197.0;-4030.0;-5630.0;-2898.0; 2540.0; -306.0;  2939.0; 1986.0 |];
+     [|   89948.0;  2103.0; 8963.0; 2695.0; 3682.0; 1648.0;  866.0; -154.0; -1963.0; -283.0 |] |]
+
+and sl =
+  [| [|   -342.0;   136.0;  -23.0;   62.0;   66.0;  -52.0;  -33.0;   17.0;     0.0;    0.0 |];
+     [|    524.0;  -149.0;  -35.0;  117.0;  151.0;  122.0;  -71.0;  -62.0;     0.0;    0.0 |];
+     [|   -105.0;  -137.0;  258.0;   35.0; -116.0;  -88.0; -112.0;  -80.0;     0.0;    0.0 |];
+     [|    854.0;  -205.0; -936.0; -240.0;  140.0; -341.0;  -97.0; -232.0;   536.0;    0.0 |];
+     [| -56980.0;  8016.0; 1012.0; 1448.0;-3024.0;-3710.0;  318.0;  503.0;  3767.0;  577.0 |];
+     [| 138606.0;-13478.0;-4964.0; 1441.0;-1319.0;-1482.0;  427.0; 1236.0; -9167.0;-1918.0 |];
+     [|  71234.0;-41116.0; 5334.0;-4935.0;-1848.0;   66.0;  434.0;-1748.0;  3780.0; -701.0 |];
+     [| -47645.0; 11647.0; 2166.0; 3194.0;  679.0;    0.0; -244.0; -419.0; -2531.0;   48.0 |] |]
+
+  
+(* Normalize angle into the range -pi <= A < +pi. *)
+let anpm a =
+  let w = mod_float a twopi in
+    if abs_float w >= pic then begin
+      if a < 0.0 then
+	w +. twopi
+      else
+	w -. twopi
+    end else
+      w
+
+(* The reference frame is equatorial and is with respect to the
+ *    mean equator and equinox of epoch j2000. *)
+let planetpv epoch np pv =
+  (* time: julian millennia since j2000. *)
+  let t = ((epoch.(0) -. j2000) +. epoch.(1)) /. jmillenia in
+    (*  compute the mean elements. *)
+  let da  = ref (a.(np).(0) +. (a.(np).(1) +. a.(np).(2) *. t ) *. t)
+  and dl  = ref ((3600.0 *. dlm.(np).(0) +. (dlm.(np).(1) +. dlm.(np).(2) *. t ) *. t) *. a2r)
+  and de  = e.(np).(0) +. (e.(np).(1) +. e.(np).(2) *. t ) *. t
+  and dp  = anpm ((3600.0 *. pi.(np).(0) +. (pi.(np).(1) +. pi.(np).(2) *. t ) *. t ) *. a2r )
+  and  di  = (3600.0 *. dinc.(np).(0) +. (dinc.(np).(1) +. dinc.(np).(2) *. t ) *. t ) *. a2r
+  and doh = anpm ((3600.0 *. omega.(np).(0) +. (omega.(np).(1) +. omega.(np).(2) *. t ) *. t ) *. a2r )     
+	      (* apply the trigonometric terms. *)
+  and dmu = 0.35953620 *. t in
+    
+  (* loop invariant *)
+  let kp = kp.(np) and kq = kq.(np) and ca = ca.(np) and sa = sa.(np)
+  and cl = cl.(np) and sl = sl.(np) in
+    for k = 0 to 7 do
+      let arga = kp.(k) *. dmu
+      and  argl = kq.(k) *. dmu in
+        da := !da +. (ca.(k) *. cos arga +. sa.(k) *. sin arga) *. 0.0000001;
+        dl := !dl +. (cl.(k) *. cos argl +. sl.(k) *. sin argl) *. 0.0000001
+    done;
+    begin let arga = kp.(8) *. dmu in
+      da := !da +. t *. (ca.(8) *. cos arga  +. sa.(8) *. sin arga ) *. 0.0000001;
+      for k = 8 to 9 do
+        let argl = kq.(k) *. dmu in
+          dl := !dl +. t *. ( cl.(k) *. cos argl +. sl.(k) *. sin argl ) *. 0.0000001
+      done;
+    end;
+
+
+    dl := mod_float !dl twopi;
+
+    (* iterative solution of kepler's equation to get eccentric anomaly. *)
+    let am = !dl -. dp in
+    let ae = ref (am +. de *. sin am)
+    and k = ref 0 in 
+    let dae = ref ((am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae)) in
+      ae := !ae +. !dae;
+      incr k;
+      while !k < 10 or abs_float !dae >= 1e-12 do
+	dae := (am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae);
+	ae := !ae +. !dae;
+	incr k
+      done;
+      
+      (* true anomaly. *)
+      let ae2 = !ae /. 2.0 in
+      let at  = 2.0 *. atan2 (sqrt ((1.0 +. de) /. (1.0 -. de)) *. sin ae2)  (cos ae2) 
+		  (* distance (au) and speed (radians per day). *)
+      and r = !da *. (1.0 -. de *. cos !ae)
+      and v = gaussk *. sqrt ((1.0 +. 1.0 /. amas.(np) ) /. (!da *. !da *. !da))
+      and si2   = sin (di /. 2.0) in
+      let xq = si2 *. cos doh
+      and xp = si2 *. sin doh
+      and tl = at +. dp in
+      let xsw = sin tl
+      and xcw = cos tl in
+      let xm2  = 2.0 *. (xp *. xcw -. xq *. xsw ) 
+      and xf = !da /. sqrt (1.0 -. de *. de)
+      and ci2 = cos (di /. 2.0) in
+      let xms = (de *. sin dp +. xsw) *. xf
+      and xmc = (de *. cos dp  +. xcw) *. xf
+      and xpxq2 = 2.0 *. xp *. xq in
+
+      (* position (j2000 ecliptic x,y,z in au). *)
+      let x = r *. (xcw -. xm2 *. xp)
+      and y = r *. (xsw +. xm2 *. xq)
+      and z = r *. (-.xm2 *. ci2) in
+
+	(* rotate to equatorial. *)
+	pv.(0).(0) <- x;
+	pv.(0).(1) <- y *. coseps -. z *. sineps;
+	pv.(0).(2) <- y *. sineps +. z *. coseps;
+
+	(* velocity (j2000 ecliptic xdot,ydot,zdot in au/d). *)
+	let x = v *. ((-1.0 +. 2.0 *. xp *. xp) *. xms +. xpxq2 *. xmc)
+	and y = v *. (( 1.0 -. 2.0 *. xq *. xq ) *. xmc -. xpxq2 *. xms)
+	and z = v *. (2.0 *. ci2 *. (xp *. xms +. xq *. xmc)) in
+
+	  (* rotate to equatorial *)
+	  pv.(1).(0) <- x;
+	  pv.(1).(1) <- y *. coseps -. z *. sineps;
+	  pv.(1).(2) <- y *. sineps +. z *. coseps
+
+
+(* Computes RA, Declination, and distance from a state vector returned by 
+ * planetpv. *)
+let radecdist state rdd =
+  (* Distance *)
+  rdd.(2) <- sqrt (state.(0).(0) *. state.(0).(0)
+		 +. state.(0).(1) *. state.(0).(1)
+		 +. state.(0).(2) *. state.(0).(2));
+  (* RA *)
+  rdd.(0) <- atan2 state.(0).(1) state.(0).(0) *. r2h;
+  if rdd.(0) < 0.0 then rdd.(0) <- rdd.(0) +. 24.0;
+  
+  (* Declination *)
+  rdd.(1) <- asin (state.(0).(2) /. rdd.(2)) *. r2d
+  
+
+
+(* Entry point. Calculate RA and Dec for noon on every day in 1900-2100 *)
+let _ =
+  let jd = [| 0.0; 0.0 |]
+  and pv = [| [| 0.0; 0.0; 0.0 |]; [| 0.0; 0.0; 0.0 |] |] 
+  and position = [| 0.0; 0.0; 0.0 |] in
+  (* Test *)
+  jd.(0) <- j2000;
+  jd.(1) <- 1.0;
+  for p = 0 to 7 do
+    planetpv jd p pv;
+    radecdist pv position;
+    Printf.printf "%d %.2f %.2f\n" p position.(0) position.(1)
+  done;
+  (* Benchmark *)
+  for i = 0 to test_loops - 1 do
+    jd.(0) <- j2000;
+    jd.(1) <- 0.0;
+    for n = 0 to test_length - 1 do
+      jd.(0) <- jd.(0) +. 1.0;
+      for p = 0 to 7 do
+	planetpv jd p pv;
+	radecdist pv position;
+      done
+    done
+  done
diff --git a/test/bdd.ml b/test/bdd.ml
new file mode 100644
index 00000000..18b05f6e
--- /dev/null
+++ b/test/bdd.ml
@@ -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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: bdd.ml,v 1.8 2003/07/16 17:30:32 doligez Exp $ *)
+
+(* Translated to Caml by Xavier Leroy *)
+(* Original code written in SML by ... *)
+
+type bdd = One | Zero | Node of bdd * int * int * bdd
+
+let rec eval bdd vars =
+  match bdd with
+    Zero -> false
+  | One -> true
+  | Node(l, v, _, h) ->
+      if vars.(v) then eval h vars else eval l vars
+
+let getId bdd = 
+  match bdd with 
+    Node(_,_,id,_) -> id
+  | Zero           -> 0
+  | One            -> 1
+
+let initSize_1 = 8*1024 - 1
+let nodeC      = ref 1
+let sz_1       = ref initSize_1
+let htab       = ref(Array.create (!sz_1+1) [])
+let n_items    = ref 0
+let hashVal x y v = x lsl 1 + y + v lsl 2
+
+let resize newSize =
+      let arr     = !htab in
+      let newSz_1 = newSize-1 in
+      let newArr  = Array.create newSize [] in
+      let rec copyBucket bucket =
+                match bucket with 
+                  []     -> ()
+                | n :: ns ->  
+                    match n with 
+                    | Node(l,v,_,h) ->
+                       let ind = hashVal (getId l) (getId h) v land newSz_1
+                       in
+                       newArr.(ind) <- (n :: newArr.(ind));
+                       copyBucket ns
+                    | _ -> assert false
+                    in
+      for n = 0 to !sz_1 do
+        copyBucket(arr.(n))
+      done;
+      htab := newArr;
+      sz_1 := newSz_1
+
+
+let rec insert idl idh v ind bucket newNode =
+        if !n_items <= !sz_1
+        then ( (!htab).(ind) <- (newNode :: bucket);
+               incr n_items )
+        else ( resize(!sz_1 + !sz_1 + 2);
+               let ind = hashVal idl idh v land (!sz_1)
+               in
+                  (!htab).(ind) <- newNode :: (!htab).(ind)
+             )
+
+
+let resetUnique () = (
+      sz_1    := initSize_1;
+      htab    := Array.create (!sz_1+1) [];
+      n_items := 0;
+      nodeC   := 1
+      )
+
+let mkNode low v high =
+   let idl = getId low in
+   let idh = getId high 
+   in
+     if idl = idh
+     then low
+     else let ind      = hashVal idl idh v land  (!sz_1) in
+          let bucket   = (!htab).(ind) in
+          let rec lookup b = 
+                    match b with 
+                      [] -> let n = Node(low, v, (incr nodeC; !nodeC), high)
+                            in
+                             insert (getId low) (getId high) v ind bucket n; n
+                    | n :: ns -> 
+                        match n with
+                        | Node(l,v',id,h) ->
+                           if v = v' && idl = getId l && idh = getId h
+                           then n else lookup ns
+                        | _ -> assert false
+           in
+             lookup bucket
+
+
+type ordering = LESS | EQUAL | GREATER
+
+let cmpVar (x : int) (y : int) =
+  if x<y then LESS else if x>y then GREATER else EQUAL 
+
+let zero = Zero
+let one  = One
+
+let mkVar x   = mkNode zero x one
+
+
+let cacheSize = 1999
+let andslot1  = Array.create cacheSize 0
+let andslot2  = Array.create cacheSize 0
+let andslot3  = Array.create cacheSize zero
+let xorslot1  = Array.create cacheSize 0
+let xorslot2  = Array.create cacheSize 0
+let xorslot3  = Array.create cacheSize zero
+let notslot1  = Array.create cacheSize 0
+let notslot2  = Array.create cacheSize one
+let hash x y  = ((x lsl 1)+y) mod cacheSize
+
+let rec not n = 
+match n with
+  Zero -> One
+| One  -> Zero
+| Node(l, v, id, r) -> let h = id mod cacheSize
+                       in
+                          if id=notslot1.(h) then notslot2.(h)
+                          else let f = mkNode (not l) v (not r)
+                               in
+                                 notslot1.(h) <- id; notslot2.(h) <- f; f
+
+let rec and2 n1 n2 = 
+match n1 with
+  Node(l1, v1, i1, r1) 
+  -> (match n2 with
+        Node(l2, v2, i2, r2)
+        -> let h = hash i1 i2
+           in
+             if i1=andslot1.(h) && i2=andslot2.(h) then andslot3.(h)
+             else let f = match cmpVar v1 v2 with
+                            EQUAL   -> mkNode (and2 l1 l2) v1 (and2 r1 r2)
+                          | LESS    -> mkNode (and2 l1 n2) v1 (and2 r1 n2)
+                          | GREATER -> mkNode (and2 n1 l2) v2 (and2 n1 r2)
+                  in
+                   andslot1.(h) <- i1; 
+                   andslot2.(h) <- i2; 
+                   andslot3.(h) <- f;
+                   f
+     | Zero -> Zero
+     | One  -> n1)
+|  Zero -> Zero
+|  One  -> n2
+
+
+let rec xor n1 n2 = 
+match n1 with
+  Node(l1, v1, i1, r1) 
+  -> (match n2 with
+        Node(l2, v2, i2, r2)
+        -> let h = hash i1 i2
+           in
+             if i1=andslot1.(h) && i2=andslot2.(h) then andslot3.(h)
+             else let f = match cmpVar v1 v2 with
+                            EQUAL   -> mkNode (xor l1 l2) v1 (xor r1 r2)
+                          | LESS    -> mkNode (xor l1 n2) v1 (xor r1 n2)
+                          | GREATER -> mkNode (xor n1 l2) v2 (xor n1 r2)
+                  in
+                   andslot1.(h) <- i1;
+                   andslot2.(h) <- i2;
+                   andslot3.(h) <- f;
+                   f
+     | Zero -> n1 
+     | One  -> not n1)
+|  Zero -> n2
+|  One  -> not n2
+
+let hwb n = 
+  let rec h i j = if i=j
+                  then mkVar i
+                  else  xor (and2 (not(mkVar j)) (h i (j-1)))
+                            (and2 (mkVar j)      (g i (j-1)))
+      and g i j = if i=j
+                  then mkVar i
+                  else xor (and2 (not(mkVar i)) (h (i+1) j)) 
+                           (and2 (mkVar i)      (g (i+1) j))
+  in
+     h 0 (n-1)
+
+(* Testing *)
+let seed = ref 0
+
+let random() =
+  seed := !seed * 25173 + 17431; !seed land 1 > 0
+
+let random_vars n =
+  let vars = Array.create n false in
+  for i = 0 to n - 1 do vars.(i) <- random() done;
+  vars
+
+let test_hwb bdd vars =
+  (* We should have
+        eval bdd vars = vars.(n-1) if n > 0
+        eval bdd vars = false if n = 0
+     where n is the number of "true" elements in vars. *)
+  let ntrue = ref 0 in
+  for i = 0 to Array.length vars - 1 do
+    if vars.(i) then incr ntrue
+  done;
+  eval bdd vars = (if !ntrue > 0 then vars.(!ntrue-1) else false)
+
+let main () =
+  let n =
+    if Array.length Sys.argv >= 2 then int_of_string Sys.argv.(1) else 20 in
+  let ntests =
+    if Array.length Sys.argv >= 3 then int_of_string Sys.argv.(2) else 50 in
+  let bdd = hwb n in
+  let succeeded = ref true in
+  for i = 1 to ntests do
+    succeeded := !succeeded && test_hwb bdd (random_vars n)
+  done;
+  if !succeeded
+  then print_string "OK\n"
+  else print_string "FAILED\n";
+  exit 0
+
+let _ = main()
diff --git a/test/boyer.ml b/test/boyer.ml
new file mode 100644
index 00000000..4a3e4fa9
--- /dev/null
+++ b/test/boyer.ml
@@ -0,0 +1,907 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: boyer.ml,v 1.8 2000/12/28 13:06:33 weis Exp $ *)
+
+(* Manipulations over terms *)
+
+type term =
+    Var of int
+  | Prop of head * term list
+and head =
+    { name: string;
+      mutable props: (term * term) list }
+
+let rec print_term = function
+    Var v ->
+      print_string "v"; print_int v
+  | Prop (head,argl) ->
+      print_string "(";
+      print_string head.name;
+      List.iter (fun t -> print_string " "; print_term t) argl;
+      print_string ")"
+ 
+let lemmas = ref ([] : head list)
+
+(* Replacement for property lists *)
+
+let get name =
+  let rec get_rec = function
+    hd1::hdl ->
+      if hd1.name = name then hd1 else get_rec hdl
+  | [] ->
+      let entry = {name = name; props = []} in
+        lemmas := entry :: !lemmas;
+        entry
+  in get_rec !lemmas
+
+let add_lemma = function
+ | Prop(_, [(Prop(headl,_) as left); right]) ->
+     headl.props <- (left, right) :: headl.props
+ | _ -> assert false
+
+(* Substitutions *)
+
+type subst = Bind of int * term
+
+let get_binding v list =
+  let rec get_rec = function
+    [] -> failwith "unbound"
+  | Bind(w,t)::rest -> if v = w  then t else get_rec rest
+  in get_rec list
+
+let apply_subst alist term =
+  let rec as_rec = function
+     Var v -> begin try get_binding v alist with Failure _ -> term end
+   | Prop (head,argl) -> Prop (head, List.map as_rec argl)
+  in as_rec term
+
+exception Unify
+
+let rec unify term1 term2 =
+  unify1 term1 term2 []
+
+and unify1 term1 term2 unify_subst =
+ match term2 with
+    Var v ->
+      begin try
+        if get_binding v unify_subst = term1
+        then unify_subst
+        else raise Unify
+      with Failure _ ->
+        Bind(v,term1) :: unify_subst
+      end
+  | Prop (head2, argl2) ->
+      match term1 with
+         Var _ -> raise Unify
+       | Prop (head1,argl1) ->
+           if head1 == head2
+           then unify1_lst argl1 argl2 unify_subst
+           else raise Unify
+
+and unify1_lst l1 l2 unify_subst =
+  match (l1, l2) with
+    ([], []) -> unify_subst
+  | (h1::r1, h2::r2) -> unify1_lst r1 r2 (unify1 h1 h2 unify_subst)
+  | _ -> raise Unify
+
+
+let rec rewrite = function
+    Var _ as term -> term
+  | Prop (head, argl) ->
+      rewrite_with_lemmas (Prop (head, List.map rewrite argl)) head.props
+and rewrite_with_lemmas term lemmas =
+  match lemmas with
+    [] ->
+      term
+  | (t1,t2)::rest ->
+      try
+        rewrite (apply_subst (unify term t1) t2)
+      with Unify ->
+        rewrite_with_lemmas term rest
+
+type cterm = CVar of int | CProp of string * cterm list
+
+let rec cterm_to_term = function
+    CVar v -> Var v
+  | CProp(p, l) -> Prop(get p, List.map cterm_to_term l)
+
+let add t = add_lemma (cterm_to_term t)
+
+let _ =
+add (CProp
+("equal",
+ [CProp ("compile",[CVar 5]); 
+  CProp
+  ("reverse",
+   [CProp ("codegen",[CProp ("optimize",[CVar 5]); CProp ("nil",[])])])]));
+add (CProp
+("equal",
+ [CProp ("eqp",[CVar 23; CVar 24]); 
+  CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 24])])]));
+add (CProp
+("equal",
+ [CProp ("gt",[CVar 23; CVar 24]); CProp ("lt",[CVar 24; CVar 23])]));
+add (CProp
+("equal",
+ [CProp ("le",[CVar 23; CVar 24]); CProp ("ge",[CVar 24; CVar 23])]));
+add (CProp
+("equal",
+ [CProp ("ge",[CVar 23; CVar 24]); CProp ("le",[CVar 24; CVar 23])]));
+add (CProp
+("equal",
+ [CProp ("boolean",[CVar 23]); 
+  CProp
+  ("or",
+   [CProp ("equal",[CVar 23; CProp ("true",[])]); 
+    CProp ("equal",[CVar 23; CProp ("false",[])])])]));
+add (CProp
+("equal",
+ [CProp ("iff",[CVar 23; CVar 24]); 
+  CProp
+  ("and",
+   [CProp ("implies",[CVar 23; CVar 24]); 
+    CProp ("implies",[CVar 24; CVar 23])])]));
+add (CProp
+("equal",
+ [CProp ("even1",[CVar 23]); 
+  CProp
+  ("if",
+   [CProp ("zerop",[CVar 23]); CProp ("true",[]); 
+    CProp ("odd",[CProp ("sub1",[CVar 23])])])]));
+add (CProp
+("equal",
+ [CProp ("countps_",[CVar 11; CVar 15]); 
+  CProp ("countps_loop",[CVar 11; CVar 15; CProp ("zero",[])])]));
+add (CProp
+("equal",
+ [CProp ("fact_",[CVar 8]); 
+  CProp ("fact_loop",[CVar 8; CProp ("one",[])])]));
+add (CProp
+("equal",
+ [CProp ("reverse_",[CVar 23]); 
+  CProp ("reverse_loop",[CVar 23; CProp ("nil",[])])]));
+add (CProp
+("equal",
+ [CProp ("divides",[CVar 23; CVar 24]); 
+  CProp ("zerop",[CProp ("remainder",[CVar 24; CVar 23])])]));
+add (CProp
+("equal",
+ [CProp ("assume_true",[CVar 21; CVar 0]); 
+  CProp ("cons",[CProp ("cons",[CVar 21; CProp ("true",[])]); CVar 0])]));
+add (CProp
+("equal",
+ [CProp ("assume_false",[CVar 21; CVar 0]); 
+  CProp ("cons",[CProp ("cons",[CVar 21; CProp ("false",[])]); CVar 0])]));
+add (CProp
+("equal",
+ [CProp ("tautology_checker",[CVar 23]); 
+  CProp ("tautologyp",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])]));
+add (CProp
+("equal",
+ [CProp ("falsify",[CVar 23]); 
+  CProp ("falsify1",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])]));
+add (CProp
+("equal",
+ [CProp ("prime",[CVar 23]); 
+  CProp
+  ("and",
+   [CProp ("not",[CProp ("zerop",[CVar 23])]); 
+    CProp
+    ("not",
+     [CProp ("equal",[CVar 23; CProp ("add1",[CProp ("zero",[])])])]); 
+    CProp ("prime1",[CVar 23; CProp ("sub1",[CVar 23])])])]));
+add (CProp
+("equal",
+ [CProp ("and",[CVar 15; CVar 16]); 
+  CProp
+  ("if",
+   [CVar 15; 
+    CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); 
+    CProp ("false",[])])]));
+add (CProp
+("equal",
+ [CProp ("or",[CVar 15; CVar 16]); 
+  CProp
+  ("if",
+   [CVar 15; CProp ("true",[]); 
+    CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); 
+    CProp ("false",[])])]));
+add (CProp
+("equal",
+ [CProp ("not",[CVar 15]); 
+  CProp ("if",[CVar 15; CProp ("false",[]); CProp ("true",[])])]));
+add (CProp
+("equal",
+ [CProp ("implies",[CVar 15; CVar 16]); 
+  CProp
+  ("if",
+   [CVar 15; 
+    CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); 
+    CProp ("true",[])])]));
+add (CProp
+("equal",
+ [CProp ("fix",[CVar 23]); 
+  CProp ("if",[CProp ("numberp",[CVar 23]); CVar 23; CProp ("zero",[])])]));
+add (CProp
+("equal",
+ [CProp ("if",[CProp ("if",[CVar 0; CVar 1; CVar 2]); CVar 3; CVar 4]); 
+  CProp
+  ("if",
+   [CVar 0; CProp ("if",[CVar 1; CVar 3; CVar 4]); 
+    CProp ("if",[CVar 2; CVar 3; CVar 4])])]));
+add (CProp
+("equal",
+ [CProp ("zerop",[CVar 23]); 
+  CProp
+  ("or",
+   [CProp ("equal",[CVar 23; CProp ("zero",[])]); 
+    CProp ("not",[CProp ("numberp",[CVar 23])])])]));
+add (CProp
+("equal",
+ [CProp ("plus",[CProp ("plus",[CVar 23; CVar 24]); CVar 25]); 
+  CProp ("plus",[CVar 23; CProp ("plus",[CVar 24; CVar 25])])]));
+add (CProp
+("equal",
+ [CProp ("equal",[CProp ("plus",[CVar 0; CVar 1]); CProp ("zero",[])]); 
+  CProp ("and",[CProp ("zerop",[CVar 0]); CProp ("zerop",[CVar 1])])]));
+add (CProp
+("equal",[CProp ("difference",[CVar 23; CVar 23]); CProp ("zero",[])]));
+add (CProp
+("equal",
+ [CProp
+  ("equal",
+   [CProp ("plus",[CVar 0; CVar 1]); CProp ("plus",[CVar 0; CVar 2])]); 
+  CProp ("equal",[CProp ("fix",[CVar 1]); CProp ("fix",[CVar 2])])]));
+add (CProp
+("equal",
+ [CProp
+  ("equal",[CProp ("zero",[]); CProp ("difference",[CVar 23; CVar 24])]); 
+  CProp ("not",[CProp ("gt",[CVar 24; CVar 23])])]));
+add (CProp
+("equal",
+ [CProp ("equal",[CVar 23; CProp ("difference",[CVar 23; CVar 24])]); 
+  CProp
+  ("and",
+   [CProp ("numberp",[CVar 23]); 
+    CProp
+    ("or",
+     [CProp ("equal",[CVar 23; CProp ("zero",[])]); 
+      CProp ("zerop",[CVar 24])])])]));
+add (CProp
+("equal",
+ [CProp
+  ("meaning",
+   [CProp ("plus_tree",[CProp ("append",[CVar 23; CVar 24])]); CVar 0]); 
+  CProp
+  ("plus",
+   [CProp ("meaning",[CProp ("plus_tree",[CVar 23]); CVar 0]); 
+    CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])]));
+add (CProp
+("equal",
+ [CProp
+  ("meaning",
+   [CProp ("plus_tree",[CProp ("plus_fringe",[CVar 23])]); CVar 0]); 
+  CProp ("fix",[CProp ("meaning",[CVar 23; CVar 0])])]));
+add (CProp
+("equal",
+ [CProp ("append",[CProp ("append",[CVar 23; CVar 24]); CVar 25]); 
+  CProp ("append",[CVar 23; CProp ("append",[CVar 24; CVar 25])])]));
+add (CProp
+("equal",
+ [CProp ("reverse",[CProp ("append",[CVar 0; CVar 1])]); 
+  CProp
+  ("append",[CProp ("reverse",[CVar 1]); CProp ("reverse",[CVar 0])])]));
+add (CProp
+("equal",
+ [CProp ("times",[CVar 23; CProp ("plus",[CVar 24; CVar 25])]); 
+  CProp
+  ("plus",
+   [CProp ("times",[CVar 23; CVar 24]); 
+    CProp ("times",[CVar 23; CVar 25])])]));
+add (CProp
+("equal",
+ [CProp ("times",[CProp ("times",[CVar 23; CVar 24]); CVar 25]); 
+  CProp ("times",[CVar 23; CProp ("times",[CVar 24; CVar 25])])]));
+add (CProp
+("equal",
+ [CProp
+  ("equal",[CProp ("times",[CVar 23; CVar 24]); CProp ("zero",[])]); 
+  CProp ("or",[CProp ("zerop",[CVar 23]); CProp ("zerop",[CVar 24])])]));
+add (CProp
+("equal",
+ [CProp ("exec",[CProp ("append",[CVar 23; CVar 24]); CVar 15; CVar 4]); 
+  CProp
+  ("exec",[CVar 24; CProp ("exec",[CVar 23; CVar 15; CVar 4]); CVar 4])]));
+add (CProp
+("equal",
+ [CProp ("mc_flatten",[CVar 23; CVar 24]); 
+  CProp ("append",[CProp ("flatten",[CVar 23]); CVar 24])]));
+add (CProp
+("equal",
+ [CProp ("member",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); 
+  CProp
+  ("or",
+   [CProp ("member",[CVar 23; CVar 0]); 
+    CProp ("member",[CVar 23; CVar 1])])]));
+add (CProp
+("equal",
+ [CProp ("member",[CVar 23; CProp ("reverse",[CVar 24])]); 
+  CProp ("member",[CVar 23; CVar 24])]));
+add (CProp
+("equal",
+ [CProp ("length",[CProp ("reverse",[CVar 23])]); 
+  CProp ("length",[CVar 23])]));
+add (CProp
+("equal",
+ [CProp ("member",[CVar 0; CProp ("intersect",[CVar 1; CVar 2])]); 
+  CProp
+  ("and",
+   [CProp ("member",[CVar 0; CVar 1]); CProp ("member",[CVar 0; CVar 2])])]));
+add (CProp
+("equal",[CProp ("nth",[CProp ("zero",[]); CVar 8]); CProp ("zero",[])]));
+add (CProp
+("equal",
+ [CProp ("exp",[CVar 8; CProp ("plus",[CVar 9; CVar 10])]); 
+  CProp
+  ("times",
+   [CProp ("exp",[CVar 8; CVar 9]); CProp ("exp",[CVar 8; CVar 10])])]));
+add (CProp
+("equal",
+ [CProp ("exp",[CVar 8; CProp ("times",[CVar 9; CVar 10])]); 
+  CProp ("exp",[CProp ("exp",[CVar 8; CVar 9]); CVar 10])]));
+add (CProp
+("equal",
+ [CProp ("reverse_loop",[CVar 23; CVar 24]); 
+  CProp ("append",[CProp ("reverse",[CVar 23]); CVar 24])]));
+add (CProp
+("equal",
+ [CProp ("reverse_loop",[CVar 23; CProp ("nil",[])]); 
+  CProp ("reverse",[CVar 23])]));
+add (CProp
+("equal",
+ [CProp ("count_list",[CVar 25; CProp ("sort_lp",[CVar 23; CVar 24])]); 
+  CProp
+  ("plus",
+   [CProp ("count_list",[CVar 25; CVar 23]); 
+    CProp ("count_list",[CVar 25; CVar 24])])]));
+add (CProp
+("equal",
+ [CProp
+  ("equal",
+   [CProp ("append",[CVar 0; CVar 1]); CProp ("append",[CVar 0; CVar 2])]); 
+  CProp ("equal",[CVar 1; CVar 2])]));
+add (CProp
+("equal",
+ [CProp
+  ("plus",
+   [CProp ("remainder",[CVar 23; CVar 24]); 
+    CProp ("times",[CVar 24; CProp ("quotient",[CVar 23; CVar 24])])]); 
+  CProp ("fix",[CVar 23])]));
+add (CProp
+("equal",
+ [CProp
+  ("power_eval",[CProp ("big_plus",[CVar 11; CVar 8; CVar 1]); CVar 1]); 
+  CProp ("plus",[CProp ("power_eval",[CVar 11; CVar 1]); CVar 8])]));
+add (CProp
+("equal",
+ [CProp
+  ("power_eval",
+   [CProp ("big_plus",[CVar 23; CVar 24; CVar 8; CVar 1]); CVar 1]); 
+  CProp
+  ("plus",
+   [CVar 8; 
+    CProp
+    ("plus",
+     [CProp ("power_eval",[CVar 23; CVar 1]); 
+      CProp ("power_eval",[CVar 24; CVar 1])])])]));
+add (CProp
+("equal",
+ [CProp ("remainder",[CVar 24; CProp ("one",[])]); CProp ("zero",[])]));
+add (CProp
+("equal",
+ [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 24]); 
+  CProp ("not",[CProp ("zerop",[CVar 24])])]));
+add (CProp
+("equal",[CProp ("remainder",[CVar 23; CVar 23]); CProp ("zero",[])]));
+add (CProp
+("equal",
+ [CProp ("lt",[CProp ("quotient",[CVar 8; CVar 9]); CVar 8]); 
+  CProp
+  ("and",
+   [CProp ("not",[CProp ("zerop",[CVar 8])]); 
+    CProp
+    ("or",
+     [CProp ("zerop",[CVar 9]); 
+      CProp ("not",[CProp ("equal",[CVar 9; CProp ("one",[])])])])])]));
+add (CProp
+("equal",
+ [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 23]); 
+  CProp
+  ("and",
+   [CProp ("not",[CProp ("zerop",[CVar 24])]); 
+    CProp ("not",[CProp ("zerop",[CVar 23])]); 
+    CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])])]));
+add (CProp
+("equal",
+ [CProp ("power_eval",[CProp ("power_rep",[CVar 8; CVar 1]); CVar 1]); 
+  CProp ("fix",[CVar 8])]));
+add (CProp
+("equal",
+ [CProp
+  ("power_eval",
+   [CProp
+    ("big_plus",
+     [CProp ("power_rep",[CVar 8; CVar 1]); 
+      CProp ("power_rep",[CVar 9; CVar 1]); CProp ("zero",[]); 
+      CVar 1]); 
+    CVar 1]); 
+  CProp ("plus",[CVar 8; CVar 9])]));
+add (CProp
+("equal",
+ [CProp ("gcd",[CVar 23; CVar 24]); CProp ("gcd",[CVar 24; CVar 23])]));
+add (CProp
+("equal",
+ [CProp ("nth",[CProp ("append",[CVar 0; CVar 1]); CVar 8]); 
+  CProp
+  ("append",
+   [CProp ("nth",[CVar 0; CVar 8]); 
+    CProp
+    ("nth",
+     [CVar 1; CProp ("difference",[CVar 8; CProp ("length",[CVar 0])])])])]));
+add (CProp
+("equal",
+ [CProp ("difference",[CProp ("plus",[CVar 23; CVar 24]); CVar 23]); 
+  CProp ("fix",[CVar 24])]));
+add (CProp
+("equal",
+ [CProp ("difference",[CProp ("plus",[CVar 24; CVar 23]); CVar 23]); 
+  CProp ("fix",[CVar 24])]));
+add (CProp
+("equal",
+ [CProp
+  ("difference",
+   [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); 
+  CProp ("difference",[CVar 24; CVar 25])]));
+add (CProp
+("equal",
+ [CProp ("times",[CVar 23; CProp ("difference",[CVar 2; CVar 22])]); 
+  CProp
+  ("difference",
+   [CProp ("times",[CVar 2; CVar 23]); 
+    CProp ("times",[CVar 22; CVar 23])])]));
+add (CProp
+("equal",
+ [CProp ("remainder",[CProp ("times",[CVar 23; CVar 25]); CVar 25]); 
+  CProp ("zero",[])]));
+add (CProp
+("equal",
+ [CProp
+  ("difference",
+   [CProp ("plus",[CVar 1; CProp ("plus",[CVar 0; CVar 2])]); CVar 0]); 
+  CProp ("plus",[CVar 1; CVar 2])]));
+add (CProp
+("equal",
+ [CProp
+  ("difference",
+   [CProp ("add1",[CProp ("plus",[CVar 24; CVar 25])]); CVar 25]); 
+  CProp ("add1",[CVar 24])]));
+add (CProp
+("equal",
+ [CProp
+  ("lt",
+   [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); 
+  CProp ("lt",[CVar 24; CVar 25])]));
+add (CProp
+("equal",
+ [CProp
+  ("lt",
+   [CProp ("times",[CVar 23; CVar 25]); 
+    CProp ("times",[CVar 24; CVar 25])]); 
+  CProp
+  ("and",
+   [CProp ("not",[CProp ("zerop",[CVar 25])]); 
+    CProp ("lt",[CVar 23; CVar 24])])]));
+add (CProp
+("equal",
+ [CProp ("lt",[CVar 24; CProp ("plus",[CVar 23; CVar 24])]); 
+  CProp ("not",[CProp ("zerop",[CVar 23])])]));
+add (CProp
+("equal",
+ [CProp
+  ("gcd",
+   [CProp ("times",[CVar 23; CVar 25]); 
+    CProp ("times",[CVar 24; CVar 25])]); 
+  CProp ("times",[CVar 25; CProp ("gcd",[CVar 23; CVar 24])])]));
+add (CProp
+("equal",
+ [CProp ("value",[CProp ("normalize",[CVar 23]); CVar 0]); 
+  CProp ("value",[CVar 23; CVar 0])]));
+add (CProp
+("equal",
+ [CProp
+  ("equal",
+   [CProp ("flatten",[CVar 23]); 
+    CProp ("cons",[CVar 24; CProp ("nil",[])])]); 
+  CProp
+  ("and",
+   [CProp ("nlistp",[CVar 23]); CProp ("equal",[CVar 23; CVar 24])])]));
+add (CProp
+("equal",
+ [CProp ("listp",[CProp ("gother",[CVar 23])]); 
+  CProp ("listp",[CVar 23])]));
+add (CProp
+("equal",
+ [CProp ("samefringe",[CVar 23; CVar 24]); 
+  CProp
+  ("equal",[CProp ("flatten",[CVar 23]); CProp ("flatten",[CVar 24])])]));
+add (CProp
+("equal",
+ [CProp
+  ("equal",
+   [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("zero",[])]); 
+  CProp
+  ("and",
+   [CProp
+    ("or",
+     [CProp ("zerop",[CVar 24]); 
+      CProp ("equal",[CVar 24; CProp ("one",[])])]); 
+    CProp ("equal",[CVar 23; CProp ("zero",[])])])]));
+add (CProp
+("equal",
+ [CProp
+  ("equal",
+   [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("one",[])]); 
+  CProp ("equal",[CVar 23; CProp ("one",[])])]));
+add (CProp
+("equal",
+ [CProp ("numberp",[CProp ("greatest_factor",[CVar 23; CVar 24])]); 
+  CProp
+  ("not",
+   [CProp
+    ("and",
+     [CProp
+      ("or",
+       [CProp ("zerop",[CVar 24]); 
+        CProp ("equal",[CVar 24; CProp ("one",[])])]); 
+      CProp ("not",[CProp ("numberp",[CVar 23])])])])]));
+add (CProp
+("equal",
+ [CProp ("times_list",[CProp ("append",[CVar 23; CVar 24])]); 
+  CProp
+  ("times",
+   [CProp ("times_list",[CVar 23]); CProp ("times_list",[CVar 24])])]));
+add (CProp
+("equal",
+ [CProp ("prime_list",[CProp ("append",[CVar 23; CVar 24])]); 
+  CProp
+  ("and",
+   [CProp ("prime_list",[CVar 23]); CProp ("prime_list",[CVar 24])])]));
+add (CProp
+("equal",
+ [CProp ("equal",[CVar 25; CProp ("times",[CVar 22; CVar 25])]); 
+  CProp
+  ("and",
+   [CProp ("numberp",[CVar 25]); 
+    CProp
+    ("or",
+     [CProp ("equal",[CVar 25; CProp ("zero",[])]); 
+      CProp ("equal",[CVar 22; CProp ("one",[])])])])]));
+add (CProp
+("equal",
+ [CProp ("ge",[CVar 23; CVar 24]); 
+  CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])]));
+add (CProp
+("equal",
+ [CProp ("equal",[CVar 23; CProp ("times",[CVar 23; CVar 24])]); 
+  CProp
+  ("or",
+   [CProp ("equal",[CVar 23; CProp ("zero",[])]); 
+    CProp
+    ("and",
+     [CProp ("numberp",[CVar 23]); 
+      CProp ("equal",[CVar 24; CProp ("one",[])])])])]));
+add (CProp
+("equal",
+ [CProp ("remainder",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); 
+  CProp ("zero",[])]));
+add (CProp
+("equal",
+ [CProp ("equal",[CProp ("times",[CVar 0; CVar 1]); CProp ("one",[])]); 
+  CProp
+  ("and",
+   [CProp ("not",[CProp ("equal",[CVar 0; CProp ("zero",[])])]); 
+    CProp ("not",[CProp ("equal",[CVar 1; CProp ("zero",[])])]); 
+    CProp ("numberp",[CVar 0]); CProp ("numberp",[CVar 1]); 
+    CProp ("equal",[CProp ("sub1",[CVar 0]); CProp ("zero",[])]); 
+    CProp ("equal",[CProp ("sub1",[CVar 1]); CProp ("zero",[])])])]));
+add (CProp
+("equal",
+ [CProp
+  ("lt",
+   [CProp ("length",[CProp ("delete",[CVar 23; CVar 11])]); 
+    CProp ("length",[CVar 11])]); 
+  CProp ("member",[CVar 23; CVar 11])]));
+add (CProp
+("equal",
+ [CProp ("sort2",[CProp ("delete",[CVar 23; CVar 11])]); 
+  CProp ("delete",[CVar 23; CProp ("sort2",[CVar 11])])]));
+add (CProp ("equal",[CProp ("dsort",[CVar 23]); CProp ("sort2",[CVar 23])]));
+add (CProp
+("equal",
+ [CProp
+  ("length",
+   [CProp
+    ("cons",
+     [CVar 0; 
+      CProp
+      ("cons",
+       [CVar 1; 
+        CProp
+        ("cons",
+         [CVar 2; 
+          CProp
+          ("cons",
+           [CVar 3; 
+            CProp ("cons",[CVar 4; CProp ("cons",[CVar 5; CVar 6])])])])])])])
+  ; CProp ("plus",[CProp ("six",[]); CProp ("length",[CVar 6])])]));
+add (CProp
+("equal",
+ [CProp
+  ("difference",
+   [CProp ("add1",[CProp ("add1",[CVar 23])]); CProp ("two",[])]); 
+  CProp ("fix",[CVar 23])]));
+add (CProp
+("equal",
+ [CProp
+  ("quotient",
+   [CProp ("plus",[CVar 23; CProp ("plus",[CVar 23; CVar 24])]); 
+    CProp ("two",[])]); 
+  CProp
+  ("plus",[CVar 23; CProp ("quotient",[CVar 24; CProp ("two",[])])])]));
+add (CProp
+("equal",
+ [CProp ("sigma",[CProp ("zero",[]); CVar 8]); 
+  CProp
+  ("quotient",
+   [CProp ("times",[CVar 8; CProp ("add1",[CVar 8])]); CProp ("two",[])])]));
+add (CProp
+("equal",
+ [CProp ("plus",[CVar 23; CProp ("add1",[CVar 24])]); 
+  CProp
+  ("if",
+   [CProp ("numberp",[CVar 24]); 
+    CProp ("add1",[CProp ("plus",[CVar 23; CVar 24])]); 
+    CProp ("add1",[CVar 23])])]));
+add (CProp
+("equal",
+ [CProp
+  ("equal",
+   [CProp ("difference",[CVar 23; CVar 24]); 
+    CProp ("difference",[CVar 25; CVar 24])]); 
+  CProp
+  ("if",
+   [CProp ("lt",[CVar 23; CVar 24]); 
+    CProp ("not",[CProp ("lt",[CVar 24; CVar 25])]); 
+    CProp
+    ("if",
+     [CProp ("lt",[CVar 25; CVar 24]); 
+      CProp ("not",[CProp ("lt",[CVar 24; CVar 23])]); 
+      CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 25])])])])])
+);
+add (CProp
+("equal",
+ [CProp
+  ("meaning",
+   [CProp ("plus_tree",[CProp ("delete",[CVar 23; CVar 24])]); CVar 0]); 
+  CProp
+  ("if",
+   [CProp ("member",[CVar 23; CVar 24]); 
+    CProp
+    ("difference",
+     [CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0]); 
+      CProp ("meaning",[CVar 23; CVar 0])]); 
+    CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])]));
+add (CProp
+("equal",
+ [CProp ("times",[CVar 23; CProp ("add1",[CVar 24])]); 
+  CProp
+  ("if",
+   [CProp ("numberp",[CVar 24]); 
+    CProp
+    ("plus",
+     [CVar 23; CProp ("times",[CVar 23; CVar 24]); 
+      CProp ("fix",[CVar 23])])])]));
+add (CProp
+("equal",
+ [CProp ("nth",[CProp ("nil",[]); CVar 8]); 
+  CProp
+  ("if",[CProp ("zerop",[CVar 8]); CProp ("nil",[]); CProp ("zero",[])])]));
+add (CProp
+("equal",
+ [CProp ("last",[CProp ("append",[CVar 0; CVar 1])]); 
+  CProp
+  ("if",
+   [CProp ("listp",[CVar 1]); CProp ("last",[CVar 1]); 
+    CProp
+    ("if",
+     [CProp ("listp",[CVar 0]); 
+      CProp ("cons",[CProp ("car",[CProp ("last",[CVar 0])]); CVar 1]); 
+      CVar 1])])]));
+add (CProp
+("equal",
+ [CProp ("equal",[CProp ("lt",[CVar 23; CVar 24]); CVar 25]); 
+  CProp
+  ("if",
+   [CProp ("lt",[CVar 23; CVar 24]); 
+    CProp ("equal",[CProp ("true",[]); CVar 25]); 
+    CProp ("equal",[CProp ("false",[]); CVar 25])])]));
+add (CProp
+("equal",
+ [CProp ("assignment",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); 
+  CProp
+  ("if",
+   [CProp ("assignedp",[CVar 23; CVar 0]); 
+    CProp ("assignment",[CVar 23; CVar 0]); 
+    CProp ("assignment",[CVar 23; CVar 1])])]));
+add (CProp
+("equal",
+ [CProp ("car",[CProp ("gother",[CVar 23])]); 
+  CProp
+  ("if",
+   [CProp ("listp",[CVar 23]); 
+    CProp ("car",[CProp ("flatten",[CVar 23])]); CProp ("zero",[])])]));
+add (CProp
+("equal",
+ [CProp ("flatten",[CProp ("cdr",[CProp ("gother",[CVar 23])])]); 
+  CProp
+  ("if",
+   [CProp ("listp",[CVar 23]); 
+    CProp ("cdr",[CProp ("flatten",[CVar 23])]); 
+    CProp ("cons",[CProp ("zero",[]); CProp ("nil",[])])])]));
+add (CProp
+("equal",
+ [CProp ("quotient",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); 
+  CProp
+  ("if",
+   [CProp ("zerop",[CVar 24]); CProp ("zero",[]); 
+    CProp ("fix",[CVar 23])])]));
+add (CProp
+("equal",
+ [CProp ("get",[CVar 9; CProp ("set",[CVar 8; CVar 21; CVar 12])]); 
+  CProp
+  ("if",
+   [CProp ("eqp",[CVar 9; CVar 8]); CVar 21; 
+    CProp ("get",[CVar 9; CVar 12])])]))
+
+(* Tautology checker *)
+
+let truep x lst =
+  match x with
+    Prop(head, _) ->
+      head.name = "true" || List.mem x lst
+  | _ ->
+      List.mem x lst
+
+and falsep x lst =
+  match x with
+    Prop(head, _) ->
+      head.name = "false" || List.mem x lst
+  | _ ->
+      List.mem x lst
+
+
+let rec tautologyp x true_lst false_lst =
+ if truep x true_lst then true else
+ if falsep x false_lst then false else begin
+(*
+ print_term x; print_newline();
+*)
+ match x with
+     Var _ -> false
+   | Prop (head,[test; yes; no]) as p ->
+        if head.name = "if" then
+          if truep test true_lst then
+            tautologyp yes true_lst false_lst
+          else if falsep test false_lst then
+            tautologyp no true_lst false_lst
+          else tautologyp yes (test::true_lst) false_lst &&
+               tautologyp no true_lst (test::false_lst)
+        else
+          false
+   | _ -> assert false
+  end
+
+
+let tautp x = 
+(*  print_term x; print_string"\n"; *)
+  let y = rewrite x in
+(*    print_term y; print_string "\n"; *)
+    tautologyp y [] []
+
+(* the benchmark *)
+
+let subst =
+[Bind(23, cterm_to_term(
+             CProp
+              ("f",
+               [CProp
+                ("plus",
+                 [CProp ("plus",[CVar 0; CVar 1]);
+                  CProp ("plus",[CVar 2; CProp ("zero",[])])])])));
+ Bind(24, cterm_to_term(
+             CProp
+              ("f",
+               [CProp
+                ("times",
+                 [CProp ("times",[CVar 0; CVar 1]);
+                  CProp ("plus",[CVar 2; CVar 3])])])));
+ Bind(25, cterm_to_term(
+             CProp
+              ("f",
+               [CProp
+                ("reverse",
+                 [CProp
+                  ("append",
+                   [CProp ("append",[CVar 0; CVar 1]);
+                    CProp ("nil",[])])])])));
+ Bind(20, cterm_to_term(
+             CProp
+              ("equal",
+               [CProp ("plus",[CVar 0; CVar 1]);
+                CProp ("difference",[CVar 23; CVar 24])])));
+ Bind(22, cterm_to_term(
+             CProp
+              ("lt",
+               [CProp ("remainder",[CVar 0; CVar 1]);
+                CProp ("member",[CVar 0; CProp ("length",[CVar 1])])])))]
+
+let term = cterm_to_term(
+           CProp
+            ("implies",
+             [CProp
+              ("and",
+               [CProp ("implies",[CVar 23; CVar 24]);
+                CProp
+                ("and",
+                 [CProp ("implies",[CVar 24; CVar 25]);
+                  CProp
+                  ("and",
+                   [CProp ("implies",[CVar 25; CVar 20]);
+                    CProp ("implies",[CVar 20; CVar 22])])])]);
+              CProp ("implies",[CVar 23; CVar 22])]))
+
+let _ =
+  if tautp (apply_subst subst term) then
+    print_string "Proved!\n"
+  else
+    print_string "Cannot prove!\n";
+  exit 0
+
+(*********
+with
+    failure s ->
+      print_string "Exception failure("; print_string s; print_string ")\n"
+  | Unify ->
+      print_string "Exception Unify\n"
+  | match_failure(file,start,stop) ->
+      print_string "Exception match_failure(";
+      print_string file;
+      print_string ",";
+      print_int start;
+      print_string ",";
+      print_int stop;
+      print_string ")\n"
+  | _ ->
+      print_string "Exception ?\n"
+
+**********)
diff --git a/test/fft.ml b/test/fft.ml
new file mode 100644
index 00000000..f11b2e66
--- /dev/null
+++ b/test/fft.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: fft.ml,v 1.8 1999/11/17 18:58:34 xleroy Exp $ *)
+
+let pi = 3.14159265358979323846
+
+let tpi = 2.0 *. pi
+
+let fft px py np =
+  let i = ref 2 in
+  let m = ref 1 in
+  
+  while (!i < np) do
+    i := !i + !i; 
+    m := !m + 1
+  done;
+
+  let n = !i in  
+  
+  if n <> np then begin
+    for i = np+1 to n do
+      px.(i) <- 0.0; 
+      py.(i) <- 0.0
+    done;
+    print_string "Use "; print_int n;
+    print_string " point fft"; print_newline()
+  end;
+
+  let n2 = ref(n+n) in
+  for k = 1 to !m-1 do
+    n2 := !n2 / 2; 
+    let n4 = !n2 / 4 in
+    let e  = tpi /. float !n2 in
+
+    for j = 1 to n4 do
+      let a = e *. float(j - 1) in
+      let a3 = 3.0 *. a in
+      let cc1 = cos(a) in
+      let ss1 = sin(a) in
+      let cc3 = cos(a3) in
+      let ss3 = sin(a3) in
+      let is = ref j in
+      let id = ref(2 * !n2) in
+  
+        while !is < n do
+          let i0r = ref !is in
+          while !i0r < n do
+             let i0 = !i0r in
+             let i1 = i0 + n4 in
+             let i2 = i1 + n4 in
+             let i3 = i2 + n4 in
+             let r1 = px.(i0) -. px.(i2) in
+             px.(i0) <- px.(i0) +. px.(i2);
+             let r2 = px.(i1) -. px.(i3) in
+             px.(i1) <- px.(i1) +. px.(i3);
+             let s1 = py.(i0) -. py.(i2) in
+             py.(i0) <- py.(i0) +. py.(i2);
+             let s2 = py.(i1) -. py.(i3) in
+             py.(i1) <- py.(i1) +. py.(i3);
+             let s3 = r1 -. s2 in
+             let r1 = r1 +. s2 in
+             let s2 = r2 -. s1 in
+             let r2 = r2 +. s1 in
+             px.(i2) <- r1*.cc1 -. s2*.ss1; 
+             py.(i2) <- -.s2*.cc1 -. r1*.ss1;
+             px.(i3) <- s3*.cc3 +. r2*.ss3;
+             py.(i3) <- r2*.cc3 -. s3*.ss3;
+             i0r := i0 + !id
+          done;
+          is := 2 * !id - !n2 + j; 
+          id := 4 * !id
+        done
+    done
+  done;
+
+(************************************)
+(*  Last stage, length=2 butterfly  *)
+(************************************)
+
+  let is = ref 1 in
+  let id = ref 4 in
+  
+  while !is < n do
+    let i0r = ref !is in
+    while !i0r <= n do
+      let i0 = !i0r in
+      let i1 = i0 + 1 in
+      let r1 = px.(i0) in
+      px.(i0) <- r1 +. px.(i1);
+      px.(i1) <- r1 -. px.(i1);
+      let r1 = py.(i0) in
+      py.(i0) <- r1 +. py.(i1);
+      py.(i1) <- r1 -. py.(i1);
+      i0r := i0 + !id
+    done;
+    is := 2 * !id - 1; 
+    id := 4 * !id
+  done;
+
+(*************************)
+(*  Bit reverse counter  *)
+(*************************)
+
+  let j = ref 1 in
+  
+  for i = 1 to n - 1 do
+    if i < !j then begin
+      let xt = px.(!j) in
+      px.(!j) <- px.(i); 
+      px.(i) <- xt;
+      let xt = py.(!j) in
+      py.(!j) <- py.(i);
+      py.(i) <- xt
+    end;
+    let k = ref(n / 2) in
+    while !k < !j do
+      j := !j - !k; 
+      k := !k / 2
+    done;
+    j := !j + !k
+  done;
+
+  n
+
+
+let test np =
+  print_int np; print_string "... "; flush stdout;
+  let enp = float np in
+  let npm = np / 2 - 1 in
+  let pxr = Array.create (np+2) 0.0
+  and pxi = Array.create (np+2) 0.0 in
+  let t = pi /. enp in
+  pxr.(1) <- (enp -. 1.0) *. 0.5;
+  pxi.(1) <- 0.0;
+  let n2 = np / 2 in
+  pxr.(n2+1) <- -0.5;
+  pxi.(n2+1) <-  0.0;
+
+  for i = 1 to npm do
+      let j = np - i in
+      pxr.(i+1) <- -0.5;
+      pxr.(j+1) <- -0.5;
+      let z = t *. float i in
+      let y = -0.5*.(cos(z)/.sin(z)) in
+      pxi.(i+1) <- y;
+      pxi.(j+1) <- -.y
+  done;
+(**
+  print_newline();
+  for i=0 to 15 do Printf.printf "%d  %f  %f\n" i pxr.(i+1) pxi.(i+1) done;
+**)
+  let _ = fft pxr pxi np in
+(**
+  for i=0 to 15 do Printf.printf "%d  %f  %f\n" i pxr.(i+1) pxi.(i+1) done;
+**)
+  let zr = ref 0.0 in
+  let zi = ref 0.0 in
+  let kr = ref 0 in
+  let ki = ref 0 in
+  for i = 0 to np-1 do
+      let a = abs_float(pxr.(i+1) -. float i) in
+      if !zr < a then begin
+         zr := a; 
+         kr := i
+      end;
+      let a = abs_float(pxi.(i+1)) in
+      if !zi < a then begin
+         zi := a; 
+         ki := i
+      end
+  done;
+  let zm = if abs_float !zr < abs_float !zi then !zi else !zr in
+  print_float zm; print_newline()
+
+
+let _ =
+  let np = ref 16 in for i = 1 to 13 do test !np; np := !np*2 done
+
diff --git a/test/fib.ml b/test/fib.ml
new file mode 100644
index 00000000..075a5f36
--- /dev/null
+++ b/test/fib.ml
@@ -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: fib.ml,v 1.4 1999/11/17 18:58:34 xleroy Exp $ *)
+
+let rec fib n =
+  if n < 2 then 1 else fib(n-1) + fib(n-2)
+
+let _ =
+  let n =
+    if Array.length Sys.argv >= 2 
+    then int_of_string Sys.argv.(1)
+    else 30 in
+  print_int(fib n); print_newline(); exit 0
+
diff --git a/test/hamming.ml b/test/hamming.ml
new file mode 100644
index 00000000..6075b79f
--- /dev/null
+++ b/test/hamming.ml
@@ -0,0 +1,105 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: hamming.ml,v 1.1 2002/01/23 17:50:19 doligez Exp $ *)
+
+(* We cannot use bignums because we don't do custom runtimes, but
+   int64 is a bit short, so we roll our own 37-digit numbers...
+*)
+
+let n0 = Int64.of_int 0;;
+let n1 = Int64.of_int 1;;
+let n2 = Int64.of_int 2;;
+let n3 = Int64.of_int 3;;
+let n5 = Int64.of_int 5;;
+
+let ( % ) = Int64.rem;;
+let ( * ) = Int64.mul;;
+let ( / ) = Int64.div;;
+let ( + ) = Int64.add;;
+let digit = Int64.of_string "1000000000000000000";;
+
+let mul n (pl, ph) = ((n * pl) % digit, n * ph + (n * pl) / digit);;
+let cmp (nl, nh) (pl, ph) =
+  if nh < ph then -1
+  else if nh > ph then 1
+  else if nl < pl then -1
+  else if nl > pl then 1
+  else 0
+;;
+
+let x2 = fun p -> mul n2 p;;
+let x3 = fun p -> mul n3 p;;
+let x5 = fun p -> mul n5 p;;
+
+let nn1 = (n1, n0);;
+
+let pr (nl, nh) =
+  if compare nh n0 = 0
+  then Printf.printf "%Ld\n" nl
+  else Printf.printf "%Ld%018Ld\n" nh nl
+;;
+
+(*
+  (* bignum version *)
+open Num;;
+let nn1 = num_of_int 1;;
+let x2 = fun p -> (num_of_int 2) */ p;;
+let x3 = fun p -> (num_of_int 3) */ p;;
+let x5 = fun p -> (num_of_int 5) */ p;;
+let cmp n p = sign_num (n -/ p);;
+let pr n = Printf.printf "%s\n" (string_of_num n);;
+*)
+
+
+(* This is where the interesting stuff begins. *)
+
+open Lazy;;
+
+type 'a lcons = Cons of 'a * 'a lcons Lazy.t;;
+type 'a llist = 'a lcons Lazy.t;;
+
+let rec map f l =
+  lazy (
+    match force l with
+    | Cons (x, ll) -> Cons (f x, map f ll)
+  )
+;;
+
+let rec merge cmp l1 l2 =
+  lazy (
+    match force l1, force l2 with
+    | Cons (x1, ll1), Cons (x2, ll2)
+       -> let c = cmp x1 x2 in
+          if c = 0
+          then Cons (x1, merge cmp ll1 ll2)
+          else if c < 0
+          then Cons (x1, merge cmp ll1 l2)
+          else Cons (x2, merge cmp l1 ll2)
+  )
+;;
+
+let rec iter_interval f l (start, stop) =
+  if stop = 0 then ()
+  else match force l with
+       | Cons (x, ll)
+          -> if start <= 0 then f x;
+             iter_interval f ll (start-1, stop-1)
+;;
+
+let rec hamming = lazy (Cons (nn1, merge cmp ham2 (merge cmp ham3 ham5)))
+    and ham2 = lazy (force (map x2 hamming))
+    and ham3 = lazy (force (map x3 hamming))
+    and ham5 = lazy (force (map x5 hamming))
+;;
+
+iter_interval pr hamming (88000, 88100);;
diff --git a/test/nucleic.ml b/test/nucleic.ml
new file mode 100644
index 00000000..c371a1da
--- /dev/null
+++ b/test/nucleic.ml
@@ -0,0 +1,3236 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: nucleic.ml,v 1.10 1999/11/17 18:58:34 xleroy Exp $ *)
+
+(* Use floating-point arithmetic *)
+
+external (+) : float -> float -> float = "%addfloat"
+external (-) : float -> float -> float = "%subfloat"
+external ( * ) : float -> float -> float = "%mulfloat"
+external (/) : float -> float -> float = "%divfloat"
+
+(* -- MATH UTILITIES --------------------------------------------------------*)
+
+let constant_pi        =  3.14159265358979323846
+let constant_minus_pi  = -3.14159265358979323846
+let constant_pi2       =  1.57079632679489661923
+let constant_minus_pi2 = -1.57079632679489661923
+
+(* -- POINTS ----------------------------------------------------------------*)
+
+type pt = { x : float; y : float; z : float }
+
+let
+pt_sub p1 p2
+  = { x = p1.x - p2.x; y = p1.y - p2.y; z = p1.z - p2.z }
+
+let
+pt_dist p1 p2
+  = let dx = p1.x - p2.x
+    and dy = p1.y - p2.y
+    and dz = p1.z - p2.z
+    in
+      sqrt ((dx * dx) + (dy * dy) + (dz * dz))
+
+let
+pt_phi p
+  = let b = atan2 p.x p.z
+    in
+      atan2 ((cos b) * p.z + (sin b) * p.x) p.y
+
+let
+pt_theta p
+  =  atan2 p.x p.z
+
+(* -- COORDINATE TRANSFORMATIONS --------------------------------------------*)
+
+(*
+   The notation for the transformations follows "Paul, R.P. (1981) Robot
+   Manipulators.  MIT Press." with the exception that our transformation
+   matrices don't have the perspective terms and are the transpose of
+   Paul's one.  See also "M\"antyl\"a, M. (1985) An Introduction to
+   Solid Modeling, Computer Science Press" Appendix A.
+  
+   The components of a transformation matrix are named like this:
+  
+    a  b  c
+    d  e  f
+    g  h  i
+   tx ty tz
+  
+   The components tx, ty, and tz are the translation vector.
+*)
+
+type tfo =
+  {a: float;   b: float;   c: float;
+   d: float;   e: float;   f: float;
+   g: float;   h: float;   i: float;
+   tx: float;  ty: float;  tz: float}
+
+let tfo_id =
+  {a=1.0; b=0.0; c=0.0;
+   d=0.0; e=1.0; f=0.0;
+   g=0.0; h=0.0; i=1.0;
+   tx=0.0; ty=0.0; tz=0.0}
+
+(*
+   The function "tfo-apply" multiplies a transformation matrix, tfo, by a
+   point vector, p.  The result is a new point.
+*)
+
+let
+tfo_apply t p
+  = { x = ((p.x * t.a) + (p.y * t.d) + (p.z * t.g) + t.tx);
+      y = ((p.x * t.b) + (p.y * t.e) + (p.z * t.h) + t.ty);
+      z = ((p.x * t.c) + (p.y * t.f) + (p.z * t.i) + t.tz) }
+
+(*
+   The function "tfo-combine" multiplies two transformation matrices A and B.
+   The result is a new matrix which cumulates the transformations described
+   by A and B.
+*)
+
+let
+tfo_combine a b =
+(* <HAND_CSE> *)
+  (* Hand elimination of common subexpressions.
+     Assumes lots of float registers (32 is perfect, 16 still OK).
+     Loses on the I386, of course. *)
+  let a_a = a.a  and a_b = a.b  and a_c = a.c  and a_d = a.d
+  and a_e = a.e  and a_f = a.f  and a_g = a.g  and a_h = a.h
+  and a_i = a.i  and a_tx = a.tx  and a_ty = a.ty  and a_tz = a.tz
+  and b_a = b.a  and b_b = b.b  and b_c = b.c  and b_d = b.d
+  and b_e = b.e  and b_f = b.f  and b_g = b.g  and b_h = b.h
+  and b_i = b.i  and b_tx = b.tx  and b_ty = b.ty  and b_tz = b.tz in
+    { a = ((a_a * b_a) + (a_b * b_d) + (a_c * b_g));
+      b = ((a_a * b_b) + (a_b * b_e) + (a_c * b_h));
+      c = ((a_a * b_c) + (a_b * b_f) + (a_c * b_i));
+      d = ((a_d * b_a) + (a_e * b_d) + (a_f * b_g));
+      e = ((a_d * b_b) + (a_e * b_e) + (a_f * b_h));
+      f = ((a_d * b_c) + (a_e * b_f) + (a_f * b_i));
+      g = ((a_g * b_a) + (a_h * b_d) + (a_i * b_g));
+      h = ((a_g * b_b) + (a_h * b_e) + (a_i * b_h));
+      i = ((a_g * b_c) + (a_h * b_f) + (a_i * b_i));
+      tx = ((a_tx * b_a) + (a_ty * b_d) + (a_tz * b_g) + b_tx);
+      ty = ((a_tx * b_b) + (a_ty * b_e) + (a_tz * b_h) + b_ty);
+      tz = ((a_tx * b_c) + (a_ty * b_f) + (a_tz * b_i) + b_tz)
+    }
+(* </HAND_CSE> *)
+ (* Original without CSE *)
+(* <NO_CSE> *) (***
+    { a = ((a.a * b.a) + (a.b * b.d) + (a.c * b.g));
+      b = ((a.a * b.b) + (a.b * b.e) + (a.c * b.h));
+      c = ((a.a * b.c) + (a.b * b.f) + (a.c * b.i));
+      d = ((a.d * b.a) + (a.e * b.d) + (a.f * b.g));
+      e = ((a.d * b.b) + (a.e * b.e) + (a.f * b.h));
+      f = ((a.d * b.c) + (a.e * b.f) + (a.f * b.i));
+      g = ((a.g * b.a) + (a.h * b.d) + (a.i * b.g));
+      h = ((a.g * b.b) + (a.h * b.e) + (a.i * b.h));
+      i = ((a.g * b.c) + (a.h * b.f) + (a.i * b.i));
+      tx = ((a.tx * b.a) + (a.ty * b.d) + (a.tz * b.g) + b.tx);
+      ty = ((a.tx * b.b) + (a.ty * b.e) + (a.tz * b.h) + b.ty);
+      tz = ((a.tx * b.c) + (a.ty * b.f) + (a.tz * b.i) + b.tz)
+    }
+  ***) (* </NO_CSE> *)
+
+(*
+   The function "tfo-inv-ortho" computes the inverse of a homogeneous
+   transformation matrix.
+*)
+
+let
+tfo_inv_ortho t =
+  { a = t.a; b = t.d; c = t.g;
+    d = t.b; e = t.e; f = t.h;
+    g = t.c; h = t.f; i = t.i;
+    tx = (-.((t.a * t.tx) + (t.b * t.ty) + (t.c * t.tz)));
+    ty = (-.((t.d * t.tx) + (t.e * t.ty) + (t.f * t.tz)));
+    tz = (-.((t.g * t.tx) + (t.h * t.ty) + (t.i * t.tz)))
+  }
+
+(*
+   Given three points p1, p2, and p3, the function "tfo-align" computes
+   a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets
+   mapped to the Y axis and p3 gets mapped to the YZ plane.
+*)
+
+let
+tfo_align p1 p2 p3
+  = let x31 = p3.x - p1.x in
+    let y31 = p3.y - p1.y in
+    let z31 = p3.z - p1.z in
+    let rotpy = pt_sub p2 p1 in
+    let phi = pt_phi rotpy in
+    let theta = pt_theta rotpy in
+    let sinp = sin phi in
+    let sint = sin theta in
+    let cosp = cos phi in
+    let cost = cos theta in
+    let sinpsint = sinp * sint in
+    let sinpcost = sinp * cost in
+    let cospsint = cosp * sint in
+    let cospcost = cosp * cost in
+    let rotpz =
+      { x = ((cost * x31) - (sint * z31));
+        y = ((sinpsint * x31) + (cosp * y31) + (sinpcost * z31));
+        z = ((cospsint * x31) + (-.(sinp * y31)) + (cospcost * z31)) } in
+    let rho = pt_theta rotpz in
+    let cosr = cos rho in
+    let sinr = sin rho in
+    let x = (-.(p1.x * cost)) + (p1.z * sint) in
+    let y = ((-.(p1.x * sinpsint)) - (p1.y * cosp)) - (p1.z * sinpcost) in
+    let z = ((-.(p1.x * cospsint) + (p1.y * sinp))) - (p1.z * cospcost) in
+      { a = ((cost * cosr) - (cospsint * sinr));
+        b = sinpsint;
+        c = ((cost * sinr) + (cospsint * cosr));
+        d = (sinp * sinr);
+        e = cosp;
+        f = (-.(sinp * cosr));
+        g = ((-.(sint * cosr)) - (cospcost * sinr));
+        h = sinpcost;
+        i = ((-.(sint * sinr) + (cospcost * cosr)));
+        tx = ((x * cosr) - (z * sinr));
+        ty = y;
+        tz = ((x * sinr + (z * cosr)))
+      }
+
+(* -- NUCLEIC ACID CONFORMATIONS DATA BASE ----------------------------------*)
+
+(*
+   Numbering of atoms follows the paper:
+  
+   IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN)
+   (1983) Abbreviations and Symbols for the Description of
+   Conformations of Polynucleotide Chains.  Eur. J. Biochem 131,
+   9-15.
+*)
+
+(* Define remaining atoms for each nucleotide type. *)
+
+type nuc_specific =
+  A of pt*pt*pt*pt*pt*pt*pt*pt
+| C of pt*pt*pt*pt*pt*pt
+| G of pt*pt*pt*pt*pt*pt*pt*pt*pt
+| U of pt*pt*pt*pt*pt
+
+(*
+   A n6 n7 n9 c8 h2 h61 h62 h8
+   C n4 o2 h41 h42 h5 h6
+   G n2 n7 n9 c8 o6 h1 h21 h22 h8
+   U o2 o4 h3 h5 h6
+*)
+
+(* Define part common to all 4 nucleotide types. *)
+
+type nuc =
+  N of tfo*tfo*tfo*tfo*
+       pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*
+       pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*
+       pt*nuc_specific
+
+(*
+    dgf_base_tfo  ; defines the standard position for wc and wc_dumas
+    p_o3'_275_tfo ; defines the standard position for the connect function
+    p_o3'_180_tfo
+    p_o3'_60_tfo
+    p o1p o2p o5' c5' h5' h5'' c4' h4' o4' c1' h1' c2' h2'' o2' h2' c3'
+    h3' o3' n1 n3 c2 c4 c5 c6
+*)
+
+let is_A = function
+     N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+      p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+      c3',h3',o3',n1,n3,c2,c4,c5,c6,A(_,_,_,_,_,_,_,_)) -> true
+   | _ -> false
+
+let is_C = function
+     N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+      p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+      c3',h3',o3',n1,n3,c2,c4,c5,c6,C(_,_,_,_,_,_)) -> true
+  | _ -> false
+
+let is_G = function
+     N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+      p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+      c3',h3',o3',n1,n3,c2,c4,c5,c6,G(_,_,_,_,_,_,_,_,_)) -> true
+  | _ -> false
+
+let
+nuc_C1'
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = c1'
+
+let
+nuc_C2 
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = c2
+
+let
+nuc_C3'
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = c3'
+
+let
+nuc_C4 
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = c4
+
+let
+nuc_C4'
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = c4'
+
+let
+nuc_N1 
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = n1
+
+let
+nuc_O3'
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = o3'
+
+let
+nuc_P
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = p
+
+let
+nuc_dgf_base_tfo
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = dgf_base_tfo
+
+let
+nuc_p_o3'_180_tfo
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = p_o3'_180_tfo
+
+let
+nuc_p_o3'_275_tfo
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = p_o3'_275_tfo
+
+let
+nuc_p_o3'_60_tfo
+(N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,_))
+  = p_o3'_60_tfo
+
+let
+rA_N9 = function
+| (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+     p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+     c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8))) -> n9
+| _ -> assert false
+
+
+let
+rG_N9   = function
+| (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+     p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+     c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8))) -> n9
+| _ -> assert false
+
+(* Database of nucleotide conformations: *)
+
+let rA
+  = N(
+      {    a= -0.0018; b= -0.8207; c=0.5714; (* dgf_base_tfo *)
+           d=0.2679; e= -0.5509; f= -0.7904;
+           g=0.9634; h=0.1517; i=0.2209;
+           tx=0.0073; ty=8.4030; tz=0.6232 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 5.4550; y = 8.2120; z = -2.8810 }, (* C5'  *)
+      { x = 5.4546; y = 8.8508; z = -1.9978 }, (* H5'  *)
+      { x = 5.7588; y = 8.6625; z = -3.8259 }, (* H5'' *)
+      { x = 6.4970; y = 7.1480; z = -2.5980 }, (* C4'  *)
+      { x = 7.4896; y = 7.5919; z = -2.5214 }, (* H4'  *)
+      { x = 6.1630; y = 6.4860; z = -1.3440 }, (* O4'  *)
+      { x = 6.5400; y = 5.1200; z = -1.4190 }, (* C1'  *)
+      { x = 7.2763; y = 4.9681; z = -0.6297 }, (* H1'  *)
+      { x = 7.1940; y = 4.8830; z = -2.7770 }, (* C2'  *)
+      { x = 6.8667; y = 3.9183; z = -3.1647 }, (* H2'' *)
+      { x = 8.5860; y = 5.0910; z = -2.6140 }, (* O2'  *)
+      { x = 8.9510; y = 4.7626; z = -1.7890 }, (* H2'  *)
+      { x = 6.5720; y = 6.0040; z = -3.6090 }, (* C3'  *)
+      { x = 5.5636; y = 5.7066; z = -3.8966 }, (* H3'  *)
+      { x = 7.3801; y = 6.3562; z = -4.7350 }, (* O3'  *)
+      { x = 4.7150; y = 0.4910; z = -0.1360 }, (* N1   *)
+      { x = 6.3490; y = 2.1730; z = -0.6020 }, (* N3   *)
+      { x = 5.9530; y = 0.9650; z = -0.2670 }, (* C2   *)
+      { x = 5.2900; y = 2.9790; z = -0.8260 }, (* C4   *)
+      { x = 3.9720; y = 2.6390; z = -0.7330 }, (* C5   *)
+      { x = 3.6770; y = 1.3160; z = -0.3660 }, (* C6 *)
+      (A (
+      { x = 2.4280; y = 0.8450; z = -0.2360 }, (* N6   *)
+      { x = 3.1660; y = 3.7290; z = -1.0360 }, (* N7   *)
+      { x = 5.3170; y = 4.2990; z = -1.1930 }, (* N9   *)
+      { x = 4.0100; y = 4.6780; z = -1.2990 }, (* C8   *)
+      { x = 6.6890; y = 0.1903; z = -0.0518 }, (* H2   *)
+      { x = 1.6470; y = 1.4460; z = -0.4040 }, (* H61  *)
+      { x = 2.2780; y = -0.1080; z = -0.0280 }, (* H62  *)
+      { x = 3.4421; y = 5.5744; z = -1.5482 }) (* H8   *)
+      )
+    )
+
+let rA01
+  = N(
+      {    a= -0.0043; b= -0.8175; c=0.5759; (* dgf_base_tfo *)
+           d=0.2617; e= -0.5567; f= -0.7884;
+           g=0.9651; h=0.1473; i=0.2164;
+           tx=0.0359; ty=8.3929; tz=0.5532 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5'  *)
+      { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5'  *)
+      { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *)
+      { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4'  *)
+      { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4'  *)
+      { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4'  *)
+      { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1'  *)
+      { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1'  *)
+      { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2'  *)
+      { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *)
+      { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2'  *)
+      { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2'  *)
+      { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3'  *)
+      { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3'  *)
+      { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3'  *)
+      { x = 4.7442; y = 0.4514; z = -0.1390 }, (* N1   *)
+      { x = 6.3687; y = 2.1459; z = -0.5926 }, (* N3   *)
+      { x = 5.9795; y = 0.9335; z = -0.2657 }, (* C2   *)
+      { x = 5.3052; y = 2.9471; z = -0.8125 }, (* C4   *)
+      { x = 3.9891; y = 2.5987; z = -0.7230 }, (* C5   *)
+      { x = 3.7016; y = 1.2717; z = -0.3647 }, (* C6 *)
+      (A (
+      { x = 2.4553; y = 0.7925; z = -0.2390 }, (* N6   *)
+      { x = 3.1770; y = 3.6859; z = -1.0198 }, (* N7   *)
+      { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9   *)
+      { x = 4.0156; y = 4.6415; z = -1.2759 }, (* C8   *)
+      { x = 6.7198; y = 0.1618; z = -0.0547 }, (* H2   *)
+      { x = 1.6709; y = 1.3900; z = -0.4039 }, (* H61  *)
+      { x = 2.3107; y = -0.1627; z = -0.0373 }, (* H62  *)
+      { x = 3.4426; y = 5.5361; z = -1.5199 }) (* H8   *)
+      )
+    )
+
+let rA02
+  = N(
+      {    a=0.5566; b=0.0449; c=0.8296; (* dgf_base_tfo *)
+           d=0.5125; e=0.7673; f= -0.3854;
+           g= -0.6538; h=0.6397; i=0.4041;
+           tx= -9.1161; ty= -3.7679; tz= -2.9968 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5'  *)
+      { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5'  *)
+      { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *)
+      { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4'  *)
+      { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4'  *)
+      { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4'  *)
+      { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1'  *)
+      { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1'  *)
+      { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2'  *)
+      { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *)
+      { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2'  *)
+      { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2'  *)
+      { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3'  *)
+      { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3'  *)
+      { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3'  *)
+      { x = 10.3245; y = 8.5459; z = 1.5467 }, (* N1   *)
+      { x = 9.8051; y = 6.9432; z = -0.1497 }, (* N3   *)
+      { x = 10.5175; y = 7.4328; z = 0.8408 }, (* C2   *)
+      { x = 8.7523; y = 7.7422; z = -0.4228 }, (* C4   *)
+      { x = 8.4257; y = 8.9060; z = 0.2099 }, (* C5   *)
+      { x = 9.2665; y = 9.3242; z = 1.2540 }, (* C6 *)
+      (A (
+      { x = 9.0664; y = 10.4462; z = 1.9610 }, (* N6   *)
+      { x = 7.2750; y = 9.4537; z = -0.3428 }, (* N7   *)
+      { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9   *)
+      { x = 6.9479; y = 8.6157; z = -1.2771 }, (* C8   *)
+      { x = 11.4063; y = 6.9047; z = 1.1859 }, (* H2   *)
+      { x = 8.2845; y = 11.0341; z = 1.7552 }, (* H61  *)
+      { x = 9.6584; y = 10.6647; z = 2.7198 }, (* H62  *)
+      { x = 6.0430; y = 8.9853; z = -1.7594 }) (* H8   *)
+      )
+    )
+let rA03
+  = N(
+      {    a= -0.5021; b=0.0731; c=0.8617; (* dgf_base_tfo *)
+           d= -0.8112; e=0.3054; f= -0.4986;
+           g= -0.2996; h= -0.9494; i= -0.0940;
+           tx=6.4273; ty= -5.1944; tz= -3.7807 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5'  *)
+      { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5'  *)
+      { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *)
+      { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4'  *)
+      { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4'  *)
+      { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4'  *)
+      { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1'  *)
+      { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1'  *)
+      { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2'  *)
+      { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *)
+      { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2'  *)
+      { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2'  *)
+      { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3'  *)
+      { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3'  *)
+      { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3'  *)
+      { x = 9.6740; y = 4.7656; z = -7.6614 }, (* N1   *)
+      { x = 9.0739; y = 4.3013; z = -5.3941 }, (* N3   *)
+      { x = 9.8416; y = 4.2192; z = -6.4581 }, (* C2   *)
+      { x = 7.9885; y = 5.0632; z = -5.6446 }, (* C4   *)
+      { x = 7.6822; y = 5.6856; z = -6.8194 }, (* C5   *)
+      { x = 8.5831; y = 5.5215; z = -7.8840 }, (* C6 *)
+      (A (
+      { x = 8.4084; y = 6.0747; z = -9.0933 }, (* N6   *)
+      { x = 6.4857; y = 6.3816; z = -6.7035 }, (* N7   *)
+      { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9   *)
+      { x = 6.1133; y = 6.1613; z = -5.4808 }, (* C8   *)
+      { x = 10.7627; y = 3.6375; z = -6.4220 }, (* H2   *)
+      { x = 7.6031; y = 6.6390; z = -9.2733 }, (* H61  *)
+      { x = 9.1004; y = 5.9708; z = -9.7893 }, (* H62  *)
+      { x = 5.1705; y = 6.6830; z = -5.3167 }) (* H8   *)
+      )
+    )
+
+let rA04
+  = N(
+      {    a= -0.5426; b= -0.8175; c=0.1929; (* dgf_base_tfo *)
+           d=0.8304; e= -0.5567; f= -0.0237;
+           g=0.1267; h=0.1473; i=0.9809;
+           tx= -0.5075; ty=8.3929; tz=0.2229 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5'  *)
+      { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5'  *)
+      { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *)
+      { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4'  *)
+      { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4'  *)
+      { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4'  *)
+      { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1'  *)
+      { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1'  *)
+      { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2'  *)
+      { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *)
+      { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2'  *)
+      { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2'  *)
+      { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3'  *)
+      { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3'  *)
+      { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3'  *)
+      { x = 3.6343; y = 2.6680; z = 2.0783 }, (* N1   *)
+      { x = 5.4505; y = 3.9805; z = 1.2446 }, (* N3   *)
+      { x = 4.7540; y = 3.3816; z = 2.1851 }, (* C2   *)
+      { x = 4.8805; y = 3.7951; z = 0.0354 }, (* C4   *)
+      { x = 3.7416; y = 3.0925; z = -0.2305 }, (* C5   *)
+      { x = 3.0873; y = 2.4980; z = 0.8606 }, (* C6 *)
+      (A (
+      { x = 1.9600; y = 1.7805; z = 0.7462 }, (* N6   *)
+      { x = 3.4605; y = 3.1184; z = -1.5906 }, (* N7   *)
+      { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9   *)
+      { x = 4.4244; y = 3.8244; z = -2.0953 }, (* C8   *)
+      { x = 5.0814; y = 3.4352; z = 3.2234 }, (* H2   *)
+      { x = 1.5423; y = 1.6454; z = -0.1520 }, (* H61  *)
+      { x = 1.5716; y = 1.3398; z = 1.5392 }, (* H62  *)
+      { x = 4.2675; y = 3.8876; z = -3.1721 }) (* H8   *)
+      )
+    )
+
+let rA05
+  = N(
+      {    a= -0.5891; b=0.0449; c=0.8068; (* dgf_base_tfo *)
+           d=0.5375; e=0.7673; f=0.3498;
+           g= -0.6034; h=0.6397; i= -0.4762;
+           tx= -0.3019; ty= -3.7679; tz= -9.5913 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5'  *)
+      { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5'  *)
+      { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *)
+      { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4'  *)
+      { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4'  *)
+      { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4'  *)
+      { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1'  *)
+      { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1'  *)
+      { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2'  *)
+      { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *)
+      { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2'  *)
+      { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2'  *)
+      { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3'  *)
+      { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3'  *)
+      { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3'  *)
+      { x = 10.2594; y = 10.6774; z = -1.0056 }, (* N1   *)
+      { x = 9.7528; y = 8.7080; z = -2.2631 }, (* N3   *)
+      { x = 10.4471; y = 9.7876; z = -1.9791 }, (* C2   *)
+      { x = 8.7271; y = 8.5575; z = -1.3991 }, (* C4   *)
+      { x = 8.4100; y = 9.3803; z = -0.3580 }, (* C5   *)
+      { x = 9.2294; y = 10.5030; z = -0.1574 }, (* C6 *)
+      (A (
+      { x = 9.0349; y = 11.3951; z = 0.8250 }, (* N6   *)
+      { x = 7.2891; y = 8.9068; z = 0.3121 }, (* N7   *)
+      { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9   *)
+      { x = 6.9702; y = 7.8292; z = -0.3353 }, (* C8   *)
+      { x = 11.3132; y = 10.0537; z = -2.5851 }, (* H2   *)
+      { x = 8.2741; y = 11.2784; z = 1.4629 }, (* H61  *)
+      { x = 9.6733; y = 12.1368; z = 0.9529 }, (* H62  *)
+      { x = 6.0888; y = 7.3990; z = 0.1403 }) (* H8   *)
+      )
+    )
+
+let rA06
+  = N(
+      {    a= -0.9815; b=0.0731; c= -0.1772; (* dgf_base_tfo *)
+           d=0.1912; e=0.3054; f= -0.9328;
+           g= -0.0141; h= -0.9494; i= -0.3137;
+           tx=5.7506; ty= -5.1944; tz=4.7470 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5'  *)
+      { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5'  *)
+      { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *)
+      { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4'  *)
+      { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4'  *)
+      { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4'  *)
+      { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1'  *)
+      { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1'  *)
+      { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2'  *)
+      { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *)
+      { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2'  *)
+      { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2'  *)
+      { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3'  *)
+      { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3'  *)
+      { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3'  *)
+      { x = 6.6624; y = 3.5061; z = -8.2986 }, (* N1   *)
+      { x = 6.5810; y = 3.2570; z = -5.9221 }, (* N3   *)
+      { x = 6.5151; y = 2.8263; z = -7.1625 }, (* C2   *)
+      { x = 6.8364; y = 4.5817; z = -5.8882 }, (* C4   *)
+      { x = 7.0116; y = 5.4064; z = -6.9609 }, (* C5   *)
+      { x = 6.9173; y = 4.8260; z = -8.2361 }, (* C6 *)
+      (A (
+      { x = 7.0668; y = 5.5163; z = -9.3763 }, (* N6   *)
+      { x = 7.2573; y = 6.7070; z = -6.5394 }, (* N7   *)
+      { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9   *)
+      { x = 7.2238; y = 6.6275; z = -5.2453 }, (* C8   *)
+      { x = 6.3146; y = 1.7741; z = -7.3641 }, (* H2   *)
+      { x = 7.2568; y = 6.4972; z = -9.3456 }, (* H61  *)
+      { x = 7.0437; y = 5.0478; z = -10.2446 }, (* H62  *)
+      { x = 7.4108; y = 7.6227; z = -4.8418 }) (* H8   *)
+      )
+    )
+
+let rA07
+  = N(
+      {    a=0.2379; b=0.1310; c= -0.9624; (* dgf_base_tfo *)
+           d= -0.5876; e= -0.7696; f= -0.2499;
+           g= -0.7734; h=0.6249; i= -0.1061;
+           tx=30.9870; ty= -26.9344; tz=42.6416 },
+      {    a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *)
+           d=0.2952; e= -0.9481; f= -0.1180;
+           g=0.5882; h=0.2777; i= -0.7595;
+           tx= -58.8919; ty= -11.3095; tz=6.0866 },
+      {    a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *)
+           d=0.9731; e= -0.0359; f= -0.2275;
+           g= -0.2290; h= -0.2532; i= -0.9399;
+           tx=3.5401; ty= -29.7913; tz=52.2796 },
+      {    a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *)
+           d= -0.1183; e=0.1805; f= -0.9764;
+           g=0.4380; h= -0.8730; i= -0.2145;
+           tx=19.9023; ty=54.8054; tz=15.2799 },
+      { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P    *)
+      { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P  *)
+      { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P  *)
+      { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5'  *)
+      { x = 39.3505; y = 8.4697; z = 42.6565 }, (* C5'  *)
+      { x = 39.1377; y = 7.5433; z = 42.1230 }, (* H5'  *)
+      { x = 39.7203; y = 9.3119; z = 42.0717 }, (* H5'' *)
+      { x = 38.0405; y = 8.9195; z = 43.2869 }, (* C4'  *)
+      { x = 37.3687; y = 9.3036; z = 42.5193 }, (* H4'  *)
+      { x = 37.4319; y = 7.8146; z = 43.9387 }, (* O4'  *)
+      { x = 37.1959; y = 8.1354; z = 45.3237 }, (* C1'  *)
+      { x = 36.1788; y = 8.5202; z = 45.3970 }, (* H1'  *)
+      { x = 38.1721; y = 9.2328; z = 45.6504 }, (* C2'  *)
+      { x = 39.1555; y = 8.7939; z = 45.8188 }, (* H2'' *)
+      { x = 37.7862; y = 10.0617; z = 46.7013 }, (* O2'  *)
+      { x = 37.3087; y = 9.6229; z = 47.4092 }, (* H2'  *)
+      { x = 38.1844; y = 10.0268; z = 44.3367 }, (* C3'  *)
+      { x = 39.1578; y = 10.5054; z = 44.2289 }, (* H3'  *)
+      { x = 37.0547; y = 10.9127; z = 44.3441 }, (* O3'  *)
+      { x = 34.8811; y = 4.2072; z = 47.5784 }, (* N1   *)
+      { x = 35.1084; y = 6.1336; z = 46.1818 }, (* N3   *)
+      { x = 34.4108; y = 5.1360; z = 46.7207 }, (* C2   *)
+      { x = 36.3908; y = 6.1224; z = 46.6053 }, (* C4   *)
+      { x = 36.9819; y = 5.2334; z = 47.4697 }, (* C5   *)
+      { x = 36.1786; y = 4.1985; z = 48.0035 }, (* C6 *)
+      (A (
+      { x = 36.6103; y = 3.2749; z = 48.8452 }, (* N6   *)
+      { x = 38.3236; y = 5.5522; z = 47.6595 }, (* N7   *)
+      { x = 37.3887; y = 7.0024; z = 46.2437 }, (* N9   *)
+      { x = 38.5055; y = 6.6096; z = 46.9057 }, (* C8   *)
+      { x = 33.3553; y = 5.0152; z = 46.4771 }, (* H2   *)
+      { x = 37.5730; y = 3.2804; z = 49.1507 }, (* H61  *)
+      { x = 35.9775; y = 2.5638; z = 49.1828 }, (* H62  *)
+      { x = 39.5461; y = 6.9184; z = 47.0041 }) (* H8   *)
+      )
+    )
+
+let rA08
+  = N(
+      {    a=0.1084; b= -0.0895; c= -0.9901; (* dgf_base_tfo *)
+           d=0.9789; e= -0.1638; f=0.1220;
+           g= -0.1731; h= -0.9824; i=0.0698;
+           tx= -2.9039; ty=47.2655; tz=33.0094 },
+      {    a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *)
+           d=0.2952; e= -0.9481; f= -0.1180;
+           g=0.5882; h=0.2777; i= -0.7595;
+           tx= -58.8919; ty= -11.3095; tz=6.0866 },
+      {    a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *)
+           d=0.9731; e= -0.0359; f= -0.2275;
+           g= -0.2290; h= -0.2532; i= -0.9399;
+           tx=3.5401; ty= -29.7913; tz=52.2796 },
+      {    a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *)
+           d= -0.1183; e=0.1805; f= -0.9764;
+           g=0.4380; h= -0.8730; i= -0.2145;
+           tx=19.9023; ty=54.8054; tz=15.2799 },
+      { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P    *)
+      { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P  *)
+      { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P  *)
+      { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5'  *)
+      { x = 39.4850; y = 8.9301; z = 44.6977 }, (* C5'  *)
+      { x = 39.0638; y = 9.8199; z = 44.2296 }, (* H5'  *)
+      { x = 40.0757; y = 9.0713; z = 45.6029 }, (* H5'' *)
+      { x = 38.3102; y = 8.0414; z = 45.0789 }, (* C4'  *)
+      { x = 37.7842; y = 8.4637; z = 45.9351 }, (* H4'  *)
+      { x = 37.4200; y = 7.9453; z = 43.9769 }, (* O4'  *)
+      { x = 37.2249; y = 6.5609; z = 43.6273 }, (* C1'  *)
+      { x = 36.3360; y = 6.2168; z = 44.1561 }, (* H1'  *)
+      { x = 38.4347; y = 5.8414; z = 44.1590 }, (* C2'  *)
+      { x = 39.2688; y = 5.9974; z = 43.4749 }, (* H2'' *)
+      { x = 38.2344; y = 4.4907; z = 44.4348 }, (* O2'  *)
+      { x = 37.6374; y = 4.0386; z = 43.8341 }, (* H2'  *)
+      { x = 38.6926; y = 6.6079; z = 45.4637 }, (* C3'  *)
+      { x = 39.7585; y = 6.5640; z = 45.6877 }, (* H3'  *)
+      { x = 37.8238; y = 6.0705; z = 46.4723 }, (* O3'  *)
+      { x = 33.9162; y = 6.2598; z = 39.7758 }, (* N1   *)
+      { x = 34.6709; y = 6.5759; z = 42.0215 }, (* N3   *)
+      { x = 33.7257; y = 6.5186; z = 41.0858 }, (* C2   *)
+      { x = 35.8935; y = 6.3324; z = 41.5018 }, (* C4   *)
+      { x = 36.2105; y = 6.0601; z = 40.1932 }, (* C5   *)
+      { x = 35.1538; y = 6.0151; z = 39.2537 }, (* C6 *)
+      (A (
+      { x = 35.3088; y = 5.7642; z = 37.9649 }, (* N6   *)
+      { x = 37.5818; y = 5.8677; z = 40.0507 }, (* N7   *)
+      { x = 37.0932; y = 6.3197; z = 42.1810 }, (* N9   *)
+      { x = 38.0509; y = 6.0354; z = 41.2635 }, (* C8   *)
+      { x = 32.6830; y = 6.6898; z = 41.3532 }, (* H2   *)
+      { x = 36.2305; y = 5.5855; z = 37.5925 }, (* H61  *)
+      { x = 34.5056; y = 5.7512; z = 37.3528 }, (* H62  *)
+      { x = 39.1318; y = 5.8993; z = 41.2285 }) (* H8   *)
+      )
+    )
+
+let rA09
+  = N(
+      {    a=0.8467; b=0.4166; c= -0.3311; (* dgf_base_tfo *)
+           d= -0.3962; e=0.9089; f=0.1303;
+           g=0.3552; h=0.0209; i=0.9346;
+           tx= -42.7319; ty= -26.6223; tz= -29.8163 },
+      {    a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *)
+           d=0.2952; e= -0.9481; f= -0.1180;
+           g=0.5882; h=0.2777; i= -0.7595;
+           tx= -58.8919; ty= -11.3095; tz=6.0866 },
+      {    a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *)
+           d=0.9731; e= -0.0359; f= -0.2275;
+           g= -0.2290; h= -0.2532; i= -0.9399;
+           tx=3.5401; ty= -29.7913; tz=52.2796 },
+      {    a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *)
+           d= -0.1183; e=0.1805; f= -0.9764;
+           g=0.4380; h= -0.8730; i= -0.2145;
+           tx=19.9023; ty=54.8054; tz=15.2799 },
+      { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P    *)
+      { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P  *)
+      { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P  *)
+      { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5'  *)
+      { x = 39.3505; y = 8.4697; z = 42.6565 }, (* C5'  *)
+      { x = 39.1377; y = 7.5433; z = 42.1230 }, (* H5'  *)
+      { x = 39.7203; y = 9.3119; z = 42.0717 }, (* H5'' *)
+      { x = 38.0405; y = 8.9195; z = 43.2869 }, (* C4'  *)
+      { x = 37.6479; y = 8.1347; z = 43.9335 }, (* H4'  *)
+      { x = 38.2691; y = 10.0933; z = 44.0524 }, (* O4'  *)
+      { x = 37.3999; y = 11.1488; z = 43.5973 }, (* C1'  *)
+      { x = 36.5061; y = 11.1221; z = 44.2206 }, (* H1'  *)
+      { x = 37.0364; y = 10.7838; z = 42.1836 }, (* C2'  *)
+      { x = 37.8636; y = 11.0489; z = 41.5252 }, (* H2'' *)
+      { x = 35.8275; y = 11.3133; z = 41.7379 }, (* O2'  *)
+      { x = 35.6214; y = 12.1896; z = 42.0714 }, (* H2'  *)
+      { x = 36.9316; y = 9.2556; z = 42.2837 }, (* C3'  *)
+      { x = 37.1778; y = 8.8260; z = 41.3127 }, (* H3'  *)
+      { x = 35.6285; y = 8.9334; z = 42.7926 }, (* O3'  *)
+      { x = 38.1482; y = 15.2833; z = 46.4641 }, (* N1   *)
+      { x = 37.3641; y = 13.0968; z = 45.9007 }, (* N3   *)
+      { x = 37.5032; y = 14.1288; z = 46.7300 }, (* C2   *)
+      { x = 37.9570; y = 13.3377; z = 44.7113 }, (* C4   *)
+      { x = 38.6397; y = 14.4660; z = 44.3267 }, (* C5   *)
+      { x = 38.7473; y = 15.5229; z = 45.2609 }, (* C6 *)
+      (A (
+      { x = 39.3720; y = 16.6649; z = 45.0297 }, (* N6   *)
+      { x = 39.1079; y = 14.3351; z = 43.0223 }, (* N7   *)
+      { x = 38.0132; y = 12.4868; z = 43.6280 }, (* N9   *)
+      { x = 38.7058; y = 13.1402; z = 42.6620 }, (* C8   *)
+      { x = 37.0731; y = 14.0857; z = 47.7306 }, (* H2   *)
+      { x = 39.8113; y = 16.8281; z = 44.1350 }, (* H61  *)
+      { x = 39.4100; y = 17.3741; z = 45.7478 }, (* H62  *)
+      { x = 39.0412; y = 12.9660; z = 41.6397 }) (* H8   *)
+      )
+    )
+
+let rA10
+  = N(
+      {    a=0.7063; b=0.6317; c= -0.3196; (* dgf_base_tfo *)
+           d= -0.0403; e= -0.4149; f= -0.9090;
+           g= -0.7068; h=0.6549; i= -0.2676;
+           tx=6.4402; ty= -52.1496; tz=30.8246 },
+      {    a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *)
+           d=0.2952; e= -0.9481; f= -0.1180;
+           g=0.5882; h=0.2777; i= -0.7595;
+           tx= -58.8919; ty= -11.3095; tz=6.0866 },
+      {    a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *)
+           d=0.9731; e= -0.0359; f= -0.2275;
+           g= -0.2290; h= -0.2532; i= -0.9399;
+           tx=3.5401; ty= -29.7913; tz=52.2796 },
+      {    a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *)
+           d= -0.1183; e=0.1805; f= -0.9764;
+           g=0.4380; h= -0.8730; i= -0.2145;
+           tx=19.9023; ty=54.8054; tz=15.2799 },
+      { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P    *)
+      { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P  *)
+      { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P  *)
+      { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5'  *)
+      { x = 39.4850; y = 8.9301; z = 44.6977 }, (* C5'  *)
+      { x = 39.0638; y = 9.8199; z = 44.2296 }, (* H5'  *)
+      { x = 40.0757; y = 9.0713; z = 45.6029 }, (* H5'' *)
+      { x = 38.3102; y = 8.0414; z = 45.0789 }, (* C4'  *)
+      { x = 37.7099; y = 7.8166; z = 44.1973 }, (* H4'  *)
+      { x = 38.8012; y = 6.8321; z = 45.6380 }, (* O4'  *)
+      { x = 38.2431; y = 6.6413; z = 46.9529 }, (* C1'  *)
+      { x = 37.3505; y = 6.0262; z = 46.8385 }, (* H1'  *)
+      { x = 37.8484; y = 8.0156; z = 47.4214 }, (* C2'  *)
+      { x = 38.7381; y = 8.5406; z = 47.7690 }, (* H2'' *)
+      { x = 36.8286; y = 8.0368; z = 48.3701 }, (* O2'  *)
+      { x = 36.8392; y = 7.3063; z = 48.9929 }, (* H2'  *)
+      { x = 37.3576; y = 8.6512; z = 46.1132 }, (* C3'  *)
+      { x = 37.5207; y = 9.7275; z = 46.1671 }, (* H3'  *)
+      { x = 35.9985; y = 8.2392; z = 45.9032 }, (* O3'  *)
+      { x = 39.9117; y = 2.2278; z = 48.8527 }, (* N1   *)
+      { x = 38.6207; y = 3.6941; z = 47.4757 }, (* N3   *)
+      { x = 38.9872; y = 2.4888; z = 47.9057 }, (* C2   *)
+      { x = 39.2961; y = 4.6720; z = 48.1174 }, (* C4   *)
+      { x = 40.2546; y = 4.5307; z = 49.0912 }, (* C5   *)
+      { x = 40.5932; y = 3.2189; z = 49.4985 }, (* C6 *)
+      (A (
+      { x = 41.4938; y = 2.9317; z = 50.4229 }, (* N6   *)
+      { x = 40.7195; y = 5.7755; z = 49.5060 }, (* N7   *)
+      { x = 39.1730; y = 6.0305; z = 47.9170 }, (* N9   *)
+      { x = 40.0413; y = 6.6250; z = 48.7728 }, (* C8   *)
+      { x = 38.5257; y = 1.5960; z = 47.4838 }, (* H2   *)
+      { x = 41.9907; y = 3.6753; z = 50.8921 }, (* H61  *)
+      { x = 41.6848; y = 1.9687; z = 50.6599 }, (* H62  *)
+      { x = 40.3571; y = 7.6321; z = 49.0452 }) (* H8   *)
+      )
+    )
+
+let rAs = [rA01;rA02;rA03;rA04;rA05;rA06;rA07;rA08;rA09;rA10]
+
+let rC
+  = N(
+      {    a= -0.0359; b= -0.8071; c=0.5894; (* dgf_base_tfo *)
+           d= -0.2669; e=0.5761; f=0.7726;
+           g= -0.9631; h= -0.1296; i= -0.2361;
+           tx=0.1584; ty=8.3434; tz=0.5434 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5'  *)
+      { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5'  *)
+      { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *)
+      { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4'  *)
+      { x = 7.2954; y = -7.6762; z = 2.4898 }, (* H4'  *)
+      { x = 6.0140; y = -6.5420; z = 1.2890 }, (* O4'  *)
+      { x = 6.4190; y = -5.1840; z = 1.3620 }, (* C1'  *)
+      { x = 7.1608; y = -5.0495; z = 0.5747 }, (* H1'  *)
+      { x = 7.0760; y = -4.9560; z = 2.7270 }, (* C2'  *)
+      { x = 6.7770; y = -3.9803; z = 3.1099 }, (* H2'' *)
+      { x = 8.4500; y = -5.1930; z = 2.5810 }, (* O2'  *)
+      { x = 8.8309; y = -4.8755; z = 1.7590 }, (* H2'  *)
+      { x = 6.4060; y = -6.0590; z = 3.5580 }, (* C3'  *)
+      { x = 5.4021; y = -5.7313; z = 3.8281 }, (* H3'  *)
+      { x = 7.1570; y = -6.4240; z = 4.7070 }, (* O3'  *)
+      { x = 5.2170; y = -4.3260; z = 1.1690 }, (* N1   *)
+      { x = 4.2960; y = -2.2560; z = 0.6290 }, (* N3   *)
+      { x = 5.4330; y = -3.0200; z = 0.7990 }, (* C2   *)
+      { x = 2.9930; y = -2.6780; z = 0.7940 }, (* C4   *)
+      { x = 2.8670; y = -4.0630; z = 1.1830 }, (* C5   *)
+      { x = 3.9570; y = -4.8300; z = 1.3550 }, (* C6 *)
+      (C (
+      { x = 2.0187; y = -1.8047; z = 0.5874 }, (* N4   *)
+      { x = 6.5470; y = -2.5560; z = 0.6290 }, (* O2   *)
+      { x = 1.0684; y = -2.1236; z = 0.7109 }, (* H41  *)
+      { x = 2.2344; y = -0.8560; z = 0.3162 }, (* H42  *)
+      { x = 1.8797; y = -4.4972; z = 1.3404 }, (* H5   *)
+      { x = 3.8479; y = -5.8742; z = 1.6480 }) (* H6   *)
+      )
+    )
+
+let rC01
+  = N(
+      {    a= -0.0137; b= -0.8012; c=0.5983; (* dgf_base_tfo *)
+           d= -0.2523; e=0.5817; f=0.7733;
+           g= -0.9675; h= -0.1404; i= -0.2101;
+           tx=0.2031; ty=8.3874; tz=0.4228 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5'  *)
+      { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5'  *)
+      { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *)
+      { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4'  *)
+      { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4'  *)
+      { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4'  *)
+      { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1'  *)
+      { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1'  *)
+      { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2'  *)
+      { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *)
+      { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2'  *)
+      { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2'  *)
+      { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3'  *)
+      { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3'  *)
+      { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3'  *)
+      { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1   *)
+      { x = 4.3777; y = -2.2062; z = 0.7229 }, (* N3   *)
+      { x = 5.5069; y = -2.9779; z = 0.9088 }, (* C2   *)
+      { x = 3.0693; y = -2.6246; z = 0.8500 }, (* C4   *)
+      { x = 2.9279; y = -4.0146; z = 1.2149 }, (* C5   *)
+      { x = 4.0101; y = -4.7892; z = 1.4017 }, (* C6 *)
+      (C (
+      { x = 2.1040; y = -1.7437; z = 0.6331 }, (* N4   *)
+      { x = 6.6267; y = -2.5166; z = 0.7728 }, (* O2   *)
+      { x = 1.1496; y = -2.0600; z = 0.7287 }, (* H41  *)
+      { x = 2.3303; y = -0.7921; z = 0.3815 }, (* H42  *)
+      { x = 1.9353; y = -4.4465; z = 1.3419 }, (* H5   *)
+      { x = 3.8895; y = -5.8371; z = 1.6762 }) (* H6   *)
+      )
+    )
+
+let rC02
+  = N(
+      {    a=0.5141; b=0.0246; c=0.8574; (* dgf_base_tfo *)
+           d= -0.5547; e= -0.7529; f=0.3542;
+           g=0.6542; h= -0.6577; i= -0.3734;
+           tx= -9.1111; ty= -3.4598; tz= -3.2939 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5'  *)
+      { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5'  *)
+      { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *)
+      { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4'  *)
+      { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4'  *)
+      { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4'  *)
+      { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1'  *)
+      { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1'  *)
+      { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2'  *)
+      { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *)
+      { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2'  *)
+      { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2'  *)
+      { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3'  *)
+      { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3'  *)
+      { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3'  *)
+      { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1   *)
+      { x = 8.6945; y = -8.7046; z = -0.2857 }, (* N3   *)
+      { x = 8.6943; y = -7.6514; z = 0.6066 }, (* C2   *)
+      { x = 7.7426; y = -9.6987; z = -0.3801 }, (* C4   *)
+      { x = 6.6642; y = -9.5742; z = 0.5722 }, (* C5   *)
+      { x = 6.6391; y = -8.5592; z = 1.4526 }, (* C6 *)
+      (C (
+      { x = 7.9033; y = -10.6371; z = -1.3010 }, (* N4   *)
+      { x = 9.5840; y = -6.8186; z = 0.6136 }, (* O2   *)
+      { x = 7.2009; y = -11.3604; z = -1.3619 }, (* H41  *)
+      { x = 8.7058; y = -10.6168; z = -1.9140 }, (* H42  *)
+      { x = 5.8585; y = -10.3083; z = 0.5822 }, (* H5   *)
+      { x = 5.8197; y = -8.4773; z = 2.1667 }) (* H6   *)
+      )
+    )
+
+let rC03
+  = N(
+      {    a= -0.4993; b=0.0476; c=0.8651; (* dgf_base_tfo *)
+           d=0.8078; e= -0.3353; f=0.4847;
+           g=0.3132; h=0.9409; i=0.1290;
+           tx=6.2989; ty= -5.2303; tz= -3.8577 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5'  *)
+      { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5'  *)
+      { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *)
+      { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4'  *)
+      { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4'  *)
+      { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4'  *)
+      { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1'  *)
+      { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1'  *)
+      { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2'  *)
+      { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *)
+      { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2'  *)
+      { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2'  *)
+      { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3'  *)
+      { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3'  *)
+      { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3'  *)
+      { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1   *)
+      { x = 7.9218; y = -5.5700; z = 6.8877 }, (* N3   *)
+      { x = 7.8908; y = -5.0886; z = 5.5944 }, (* C2   *)
+      { x = 6.9789; y = -6.3827; z = 7.4823 }, (* C4   *)
+      { x = 5.8742; y = -6.7319; z = 6.6202 }, (* C5   *)
+      { x = 5.8182; y = -6.2769; z = 5.3570 }, (* C6 *)
+      (C (
+      { x = 7.1702; y = -6.7511; z = 8.7402 }, (* N4   *)
+      { x = 8.7747; y = -4.3728; z = 5.1568 }, (* O2   *)
+      { x = 6.4741; y = -7.3461; z = 9.1662 }, (* H41  *)
+      { x = 7.9889; y = -6.4396; z = 9.2429 }, (* H42  *)
+      { x = 5.0736; y = -7.3713; z = 6.9922 }, (* H5   *)
+      { x = 4.9784; y = -6.5473; z = 4.7170 }) (* H6   *)
+      )
+    )
+
+let rC04
+  = N(
+      {    a= -0.5669; b= -0.8012; c=0.1918; (* dgf_base_tfo *)
+           d= -0.8129; e=0.5817; f=0.0273;
+           g= -0.1334; h= -0.1404; i= -0.9811;
+           tx= -0.3279; ty=8.3874; tz=0.3355 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5'  *)
+      { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5'  *)
+      { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *)
+      { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4'  *)
+      { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4'  *)
+      { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4'  *)
+      { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1'  *)
+      { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1'  *)
+      { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2'  *)
+      { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *)
+      { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2'  *)
+      { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2'  *)
+      { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3'  *)
+      { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3'  *)
+      { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3'  *)
+      { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1   *)
+      { x = 3.8961; y = -3.0896; z = -0.1893 }, (* N3   *)
+      { x = 5.0095; y = -3.8907; z = -0.0346 }, (* C2   *)
+      { x = 3.0480; y = -2.6632; z = 0.8116 }, (* C4   *)
+      { x = 3.4093; y = -3.1310; z = 2.1292 }, (* C5   *)
+      { x = 4.4878; y = -3.9124; z = 2.3088 }, (* C6 *)
+      (C (
+      { x = 2.0216; y = -1.8941; z = 0.4804 }, (* N4   *)
+      { x = 5.7005; y = -4.2164; z = -0.9842 }, (* O2   *)
+      { x = 1.4067; y = -1.5873; z = 1.2205 }, (* H41  *)
+      { x = 1.8721; y = -1.6319; z = -0.4835 }, (* H42  *)
+      { x = 2.8048; y = -2.8507; z = 2.9918 }, (* H5   *)
+      { x = 4.7491; y = -4.2593; z = 3.3085 }) (* H6   *)
+      )
+    )
+
+let rC05
+  = N(
+      {    a= -0.6298; b=0.0246; c=0.7763; (* dgf_base_tfo *)
+           d= -0.5226; e= -0.7529; f= -0.4001;
+           g=0.5746; h= -0.6577; i=0.4870;
+           tx= -0.0208; ty= -3.4598; tz= -9.6882 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5'  *)
+      { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5'  *)
+      { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *)
+      { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4'  *)
+      { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4'  *)
+      { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4'  *)
+      { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1'  *)
+      { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1'  *)
+      { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2'  *)
+      { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *)
+      { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2'  *)
+      { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2'  *)
+      { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3'  *)
+      { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3'  *)
+      { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3'  *)
+      { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1   *)
+      { x = 8.5977; y = -9.5977; z = 0.7329 }, (* N3   *)
+      { x = 8.5951; y = -8.5745; z = 1.6594 }, (* C2   *)
+      { x = 7.7372; y = -9.7371; z = -0.3364 }, (* C4   *)
+      { x = 6.7596; y = -8.6801; z = -0.4476 }, (* C5   *)
+      { x = 6.7338; y = -7.6721; z = 0.4408 }, (* C6 *)
+      (C (
+      { x = 7.8849; y = -10.7881; z = -1.1289 }, (* N4   *)
+      { x = 9.3993; y = -8.5377; z = 2.5743 }, (* O2   *)
+      { x = 7.2499; y = -10.8809; z = -1.9088 }, (* H41  *)
+      { x = 8.6122; y = -11.4649; z = -0.9468 }, (* H42  *)
+      { x = 6.0317; y = -8.6941; z = -1.2588 }, (* H5   *)
+      { x = 5.9901; y = -6.8809; z = 0.3459 }) (* H6   *)
+      )
+    )
+
+let rC06
+  = N(
+      {    a= -0.9837; b=0.0476; c= -0.1733; (* dgf_base_tfo *)
+           d= -0.1792; e= -0.3353; f=0.9249;
+           g= -0.0141; h=0.9409; i=0.3384;
+           tx=5.7793; ty= -5.2303; tz=4.5997 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5'  *)
+      { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5'  *)
+      { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *)
+      { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4'  *)
+      { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4'  *)
+      { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4'  *)
+      { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1'  *)
+      { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1'  *)
+      { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2'  *)
+      { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *)
+      { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2'  *)
+      { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2'  *)
+      { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3'  *)
+      { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3'  *)
+      { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3'  *)
+      { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1   *)
+      { x = 6.6920; y = -5.0495; z = 7.1354 }, (* N3   *)
+      { x = 6.6201; y = -4.5500; z = 5.8506 }, (* C2   *)
+      { x = 6.9254; y = -6.3614; z = 7.4926 }, (* C4   *)
+      { x = 7.1046; y = -7.2543; z = 6.3718 }, (* C5   *)
+      { x = 7.0391; y = -6.7951; z = 5.1106 }, (* C6 *)
+      (C (
+      { x = 6.9614; y = -6.6648; z = 8.7815 }, (* N4   *)
+      { x = 6.4083; y = -3.3696; z = 5.6340 }, (* O2   *)
+      { x = 7.1329; y = -7.6280; z = 9.0324 }, (* H41  *)
+      { x = 6.8204; y = -5.9469; z = 9.4777 }, (* H42  *)
+      { x = 7.2954; y = -8.3135; z = 6.5440 }, (* H5   *)
+      { x = 7.1753; y = -7.4798; z = 4.2735 }) (* H6   *)
+      )
+    )
+
+let rC07
+  = N(
+      {    a=0.0033; b=0.2720; c= -0.9623; (* dgf_base_tfo *)
+           d=0.3013; e= -0.9179; f= -0.2584;
+           g= -0.9535; h= -0.2891; i= -0.0850;
+           tx=43.0403; ty=13.7233; tz=34.5710 },
+      {    a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *)
+           d=0.0302; e= -0.7316; f=0.6811;
+           g=0.3938; h= -0.6176; i= -0.6808;
+           tx= -48.4330; ty=26.3254; tz=13.6383 },
+      {    a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *)
+           d=0.7581; e=0.4893; f=0.4311;
+           g=0.6345; h= -0.4010; i= -0.6607;
+           tx= -31.9784; ty= -13.4285; tz=44.9650 },
+      {    a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *)
+           d= -0.6890; e=0.5694; f= -0.4484;
+           g=0.3694; h= -0.2564; i= -0.8932;
+           tx=12.1105; ty=30.8774; tz=46.0946 },
+      { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P    *)
+      { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P  *)
+      { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P  *)
+      { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5'  *)
+      { x = 30.8152; y = 11.1619; z = 46.2003 }, (* C5'  *)
+      { x = 30.4519; y = 10.9454; z = 45.1957 }, (* H5'  *)
+      { x = 31.0379; y = 12.2016; z = 46.4400 }, (* H5'' *)
+      { x = 29.7081; y = 10.7448; z = 47.1428 }, (* C4'  *)
+      { x = 28.8710; y = 11.4416; z = 47.0982 }, (* H4'  *)
+      { x = 29.2550; y = 9.4394; z = 46.8162 }, (* O4'  *)
+      { x = 29.3907; y = 8.5625; z = 47.9460 }, (* C1'  *)
+      { x = 28.4416; y = 8.5669; z = 48.4819 }, (* H1'  *)
+      { x = 30.4468; y = 9.2031; z = 48.7952 }, (* C2'  *)
+      { x = 31.4222; y = 8.9651; z = 48.3709 }, (* H2'' *)
+      { x = 30.3701; y = 8.9157; z = 50.1624 }, (* O2'  *)
+      { x = 30.0652; y = 8.0304; z = 50.3740 }, (* H2'  *)
+      { x = 30.1622; y = 10.6879; z = 48.6120 }, (* C3'  *)
+      { x = 31.0952; y = 11.2399; z = 48.7254 }, (* H3'  *)
+      { x = 29.1076; y = 11.1535; z = 49.4702 }, (* O3'  *)
+      { x = 29.7883; y = 7.2209; z = 47.5235 }, (* N1   *)
+      { x = 29.1825; y = 5.0438; z = 46.8275 }, (* N3   *)
+      { x = 28.8008; y = 6.2912; z = 47.2263 }, (* C2   *)
+      { x = 30.4888; y = 4.6890; z = 46.7186 }, (* C4   *)
+      { x = 31.5034; y = 5.6405; z = 47.0249 }, (* C5   *)
+      { x = 31.1091; y = 6.8691; z = 47.4156 }, (* C6 *)
+      (C (
+      { x = 30.8109; y = 3.4584; z = 46.3336 }, (* N4   *)
+      { x = 27.6171; y = 6.5989; z = 47.3189 }, (* O2   *)
+      { x = 31.7923; y = 3.2301; z = 46.2638 }, (* H41  *)
+      { x = 30.0880; y = 2.7857; z = 46.1215 }, (* H42  *)
+      { x = 32.5542; y = 5.3634; z = 46.9395 }, (* H5   *)
+      { x = 31.8523; y = 7.6279; z = 47.6603 }) (* H6   *)
+      )
+    )
+
+let rC08
+  = N(
+      {    a=0.0797; b= -0.6026; c= -0.7941; (* dgf_base_tfo *)
+           d=0.7939; e=0.5201; f= -0.3150;
+           g=0.6028; h= -0.6054; i=0.5198;
+           tx= -36.8341; ty=41.5293; tz=1.6628 },
+      {    a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *)
+           d=0.0302; e= -0.7316; f=0.6811;
+           g=0.3938; h= -0.6176; i= -0.6808;
+           tx= -48.4330; ty=26.3254; tz=13.6383 },
+      {    a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *)
+           d=0.7581; e=0.4893; f=0.4311;
+           g=0.6345; h= -0.4010; i= -0.6607;
+           tx= -31.9784; ty= -13.4285; tz=44.9650 },
+      {    a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *)
+           d= -0.6890; e=0.5694; f= -0.4484;
+           g=0.3694; h= -0.2564; i= -0.8932;
+           tx=12.1105; ty=30.8774; tz=46.0946 },
+      { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P    *)
+      { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P  *)
+      { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P  *)
+      { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5'  *)
+      { x = 31.8779; y = 9.9369; z = 47.8760 }, (* C5'  *)
+      { x = 31.3239; y = 10.6931; z = 48.4322 }, (* H5'  *)
+      { x = 32.8647; y = 9.6624; z = 48.2489 }, (* H5'' *)
+      { x = 31.0429; y = 8.6773; z = 47.9401 }, (* C4'  *)
+      { x = 31.0779; y = 8.2331; z = 48.9349 }, (* H4'  *)
+      { x = 29.6956; y = 8.9669; z = 47.5983 }, (* O4'  *)
+      { x = 29.2784; y = 8.1700; z = 46.4782 }, (* C1'  *)
+      { x = 28.8006; y = 7.2731; z = 46.8722 }, (* H1'  *)
+      { x = 30.5544; y = 7.7940; z = 45.7875 }, (* C2'  *)
+      { x = 30.8837; y = 8.6410; z = 45.1856 }, (* H2'' *)
+      { x = 30.5100; y = 6.6007; z = 45.0582 }, (* O2'  *)
+      { x = 29.6694; y = 6.4168; z = 44.6326 }, (* H2'  *)
+      { x = 31.5146; y = 7.5954; z = 46.9527 }, (* C3'  *)
+      { x = 32.5255; y = 7.8261; z = 46.6166 }, (* H3'  *)
+      { x = 31.3876; y = 6.2951; z = 47.5516 }, (* O3'  *)
+      { x = 28.3976; y = 8.9302; z = 45.5933 }, (* N1   *)
+      { x = 26.2155; y = 9.6135; z = 44.9910 }, (* N3   *)
+      { x = 27.0281; y = 8.8961; z = 45.8192 }, (* C2   *)
+      { x = 26.7044; y = 10.3489; z = 43.9595 }, (* C4   *)
+      { x = 28.1088; y = 10.3837; z = 43.7247 }, (* C5   *)
+      { x = 28.8978; y = 9.6708; z = 44.5535 }, (* C6 *)
+      (C (
+      { x = 25.8715; y = 11.0249; z = 43.1749 }, (* N4   *)
+      { x = 26.5733; y = 8.2371; z = 46.7484 }, (* O2   *)
+      { x = 26.2707; y = 11.5609; z = 42.4177 }, (* H41  *)
+      { x = 24.8760; y = 10.9939; z = 43.3427 }, (* H42  *)
+      { x = 28.5089; y = 10.9722; z = 42.8990 }, (* H5   *)
+      { x = 29.9782; y = 9.6687; z = 44.4097 }) (* H6   *)
+      )
+    )
+
+let rC09
+  = N(
+      {    a=0.8727; b=0.4760; c= -0.1091; (* dgf_base_tfo *)
+           d= -0.4188; e=0.6148; f= -0.6682;
+           g= -0.2510; h=0.6289; i=0.7359;
+           tx= -8.1687; ty= -52.0761; tz= -25.0726 },
+      {    a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *)
+           d=0.0302; e= -0.7316; f=0.6811;
+           g=0.3938; h= -0.6176; i= -0.6808;
+           tx= -48.4330; ty=26.3254; tz=13.6383 },
+      {    a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *)
+           d=0.7581; e=0.4893; f=0.4311;
+           g=0.6345; h= -0.4010; i= -0.6607;
+           tx= -31.9784; ty= -13.4285; tz=44.9650 },
+      {    a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *)
+           d= -0.6890; e=0.5694; f= -0.4484;
+           g=0.3694; h= -0.2564; i= -0.8932;
+           tx=12.1105; ty=30.8774; tz=46.0946 },
+      { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P    *)
+      { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P  *)
+      { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P  *)
+      { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5'  *)
+      { x = 30.8152; y = 11.1619; z = 46.2003 }, (* C5'  *)
+      { x = 30.4519; y = 10.9454; z = 45.1957 }, (* H5'  *)
+      { x = 31.0379; y = 12.2016; z = 46.4400 }, (* H5'' *)
+      { x = 29.7081; y = 10.7448; z = 47.1428 }, (* C4'  *)
+      { x = 29.4506; y = 9.6945; z = 47.0059 }, (* H4'  *)
+      { x = 30.1045; y = 10.9634; z = 48.4885 }, (* O4'  *)
+      { x = 29.1794; y = 11.8418; z = 49.1490 }, (* C1'  *)
+      { x = 28.4388; y = 11.2210; z = 49.6533 }, (* H1'  *)
+      { x = 28.5211; y = 12.6008; z = 48.0367 }, (* C2'  *)
+      { x = 29.1947; y = 13.3949; z = 47.7147 }, (* H2'' *)
+      { x = 27.2316; y = 13.0683; z = 48.3134 }, (* O2'  *)
+      { x = 27.0851; y = 13.3391; z = 49.2227 }, (* H2'  *)
+      { x = 28.4131; y = 11.5507; z = 46.9391 }, (* C3'  *)
+      { x = 28.4451; y = 12.0512; z = 45.9713 }, (* H3'  *)
+      { x = 27.2707; y = 10.6955; z = 47.1097 }, (* O3'  *)
+      { x = 29.8751; y = 12.7405; z = 50.0682 }, (* N1   *)
+      { x = 30.7172; y = 13.1841; z = 52.2328 }, (* N3   *)
+      { x = 30.0617; y = 12.3404; z = 51.3847 }, (* C2   *)
+      { x = 31.1834; y = 14.3941; z = 51.8297 }, (* C4   *)
+      { x = 30.9913; y = 14.8074; z = 50.4803 }, (* C5   *)
+      { x = 30.3434; y = 13.9610; z = 49.6548 }, (* C6 *)
+      (C (
+      { x = 31.8090; y = 15.1847; z = 52.6957 }, (* N4   *)
+      { x = 29.6470; y = 11.2494; z = 51.7616 }, (* O2   *)
+      { x = 32.1422; y = 16.0774; z = 52.3606 }, (* H41  *)
+      { x = 31.9392; y = 14.8893; z = 53.6527 }, (* H42  *)
+      { x = 31.3632; y = 15.7771; z = 50.1491 }, (* H5   *)
+      { x = 30.1742; y = 14.2374; z = 48.6141 }) (* H6   *)
+      )
+    )
+
+let rC10
+  = N(
+      {    a=0.1549; b=0.8710; c= -0.4663; (* dgf_base_tfo *)
+           d=0.6768; e= -0.4374; f= -0.5921;
+           g= -0.7197; h= -0.2239; i= -0.6572;
+           tx=25.2447; ty= -14.1920; tz=50.3201 },
+      {    a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *)
+           d=0.0302; e= -0.7316; f=0.6811;
+           g=0.3938; h= -0.6176; i= -0.6808;
+           tx= -48.4330; ty=26.3254; tz=13.6383 },
+      {    a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *)
+           d=0.7581; e=0.4893; f=0.4311;
+           g=0.6345; h= -0.4010; i= -0.6607;
+           tx= -31.9784; ty= -13.4285; tz=44.9650 },
+      {    a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *)
+           d= -0.6890; e=0.5694; f= -0.4484;
+           g=0.3694; h= -0.2564; i= -0.8932;
+           tx=12.1105; ty=30.8774; tz=46.0946 },
+      { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P    *)
+      { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P  *)
+      { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P  *)
+      { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5'  *)
+      { x = 31.8779; y = 9.9369; z = 47.8760 }, (* C5'  *)
+      { x = 31.3239; y = 10.6931; z = 48.4322 }, (* H5'  *)
+      { x = 32.8647; y = 9.6624; z = 48.2489 }, (* H5'' *)
+      { x = 31.0429; y = 8.6773; z = 47.9401 }, (* C4'  *)
+      { x = 30.0440; y = 8.8473; z = 47.5383 }, (* H4'  *)
+      { x = 31.6749; y = 7.6351; z = 47.2119 }, (* O4'  *)
+      { x = 31.9159; y = 6.5022; z = 48.0616 }, (* C1'  *)
+      { x = 31.0691; y = 5.8243; z = 47.9544 }, (* H1'  *)
+      { x = 31.9300; y = 7.0685; z = 49.4493 }, (* C2'  *)
+      { x = 32.9024; y = 7.5288; z = 49.6245 }, (* H2'' *)
+      { x = 31.5672; y = 6.1750; z = 50.4632 }, (* O2'  *)
+      { x = 31.8416; y = 5.2663; z = 50.3200 }, (* H2'  *)
+      { x = 30.8618; y = 8.1514; z = 49.3749 }, (* C3'  *)
+      { x = 31.1122; y = 8.9396; z = 50.0850 }, (* H3'  *)
+      { x = 29.5351; y = 7.6245; z = 49.5409 }, (* O3'  *)
+      { x = 33.1890; y = 5.8629; z = 47.7343 }, (* N1   *)
+      { x = 34.4004; y = 4.2636; z = 46.4828 }, (* N3   *)
+      { x = 33.2062; y = 4.8497; z = 46.7851 }, (* C2   *)
+      { x = 35.5600; y = 4.6374; z = 47.0822 }, (* C4   *)
+      { x = 35.5444; y = 5.6751; z = 48.0577 }, (* C5   *)
+      { x = 34.3565; y = 6.2450; z = 48.3432 }, (* C6 *)
+      (C (
+      { x = 36.6977; y = 4.0305; z = 46.7598 }, (* N4   *)
+      { x = 32.1661; y = 4.5034; z = 46.2348 }, (* O2   *)
+      { x = 37.5405; y = 4.3347; z = 47.2259 }, (* H41  *)
+      { x = 36.7033; y = 3.2923; z = 46.0706 }, (* H42  *)
+      { x = 36.4713; y = 5.9811; z = 48.5428 }, (* H5   *)
+      { x = 34.2986; y = 7.0426; z = 49.0839 }) (* H6   *)
+      )
+    )
+
+let rCs = [rC01;rC02;rC03;rC04;rC05;rC06;rC07;rC08;rC09;rC10]
+
+let rG
+  = N(
+      {    a= -0.0018; b= -0.8207; c=0.5714; (* dgf_base_tfo *)
+           d=0.2679; e= -0.5509; f= -0.7904;
+           g=0.9634; h=0.1517; i=0.2209;
+           tx=0.0073; ty=8.4030; tz=0.6232 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 5.4550; y = 8.2120; z = -2.8810 }, (* C5'  *)
+      { x = 5.4546; y = 8.8508; z = -1.9978 }, (* H5'  *)
+      { x = 5.7588; y = 8.6625; z = -3.8259 }, (* H5'' *)
+      { x = 6.4970; y = 7.1480; z = -2.5980 }, (* C4'  *)
+      { x = 7.4896; y = 7.5919; z = -2.5214 }, (* H4'  *)
+      { x = 6.1630; y = 6.4860; z = -1.3440 }, (* O4'  *)
+      { x = 6.5400; y = 5.1200; z = -1.4190 }, (* C1'  *)
+      { x = 7.2763; y = 4.9681; z = -0.6297 }, (* H1'  *)
+      { x = 7.1940; y = 4.8830; z = -2.7770 }, (* C2'  *)
+      { x = 6.8667; y = 3.9183; z = -3.1647 }, (* H2'' *)
+      { x = 8.5860; y = 5.0910; z = -2.6140 }, (* O2'  *)
+      { x = 8.9510; y = 4.7626; z = -1.7890 }, (* H2'  *)
+      { x = 6.5720; y = 6.0040; z = -3.6090 }, (* C3'  *)
+      { x = 5.5636; y = 5.7066; z = -3.8966 }, (* H3'  *)
+      { x = 7.3801; y = 6.3562; z = -4.7350 }, (* O3'  *)
+      { x = 4.7150; y = 0.4910; z = -0.1360 }, (* N1   *)
+      { x = 6.3490; y = 2.1730; z = -0.6020 }, (* N3   *)
+      { x = 5.9530; y = 0.9650; z = -0.2670 }, (* C2   *)
+      { x = 5.2900; y = 2.9790; z = -0.8260 }, (* C4   *)
+      { x = 3.9720; y = 2.6390; z = -0.7330 }, (* C5   *)
+      { x = 3.6770; y = 1.3160; z = -0.3660 }, (* C6 *)
+      (G (
+      { x = 6.8426; y = 0.0056; z = -0.0019 }, (* N2   *)
+      { x = 3.1660; y = 3.7290; z = -1.0360 }, (* N7   *)
+      { x = 5.3170; y = 4.2990; z = -1.1930 }, (* N9   *)
+      { x = 4.0100; y = 4.6780; z = -1.2990 }, (* C8   *)
+      { x = 2.4280; y = 0.8450; z = -0.2360 }, (* O6   *)
+      { x = 4.6151; y = -0.4677; z = 0.1305 }, (* H1   *)
+      { x = 6.6463; y = -0.9463; z = 0.2729 }, (* H21  *)
+      { x = 7.8170; y = 0.2642; z = -0.0640 }, (* H22  *)
+      { x = 3.4421; y = 5.5744; z = -1.5482 }) (* H8   *)
+      )
+    )
+
+let rG01
+  = N(
+      {    a= -0.0043; b= -0.8175; c=0.5759; (* dgf_base_tfo *)
+           d=0.2617; e= -0.5567; f= -0.7884;
+           g=0.9651; h=0.1473; i=0.2164;
+           tx=0.0359; ty=8.3929; tz=0.5532 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5'  *)
+      { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5'  *)
+      { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *)
+      { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4'  *)
+      { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4'  *)
+      { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4'  *)
+      { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1'  *)
+      { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1'  *)
+      { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2'  *)
+      { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *)
+      { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2'  *)
+      { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2'  *)
+      { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3'  *)
+      { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3'  *)
+      { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3'  *)
+      { x = 4.7442; y = 0.4514; z = -0.1390 }, (* N1   *)
+      { x = 6.3687; y = 2.1459; z = -0.5926 }, (* N3   *)
+      { x = 5.9795; y = 0.9335; z = -0.2657 }, (* C2   *)
+      { x = 5.3052; y = 2.9471; z = -0.8125 }, (* C4   *)
+      { x = 3.9891; y = 2.5987; z = -0.7230 }, (* C5   *)
+      { x = 3.7016; y = 1.2717; z = -0.3647 }, (* C6 *)
+      (G (
+      { x = 6.8745; y = -0.0224; z = -0.0058 }, (* N2   *)
+      { x = 3.1770; y = 3.6859; z = -1.0198 }, (* N7   *)
+      { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9   *)
+      { x = 4.0156; y = 4.6415; z = -1.2759 }, (* C8   *)
+      { x = 2.4553; y = 0.7925; z = -0.2390 }, (* O6   *)
+      { x = 4.6497; y = -0.5095; z = 0.1212 }, (* H1   *)
+      { x = 6.6836; y = -0.9771; z = 0.2627 }, (* H21  *)
+      { x = 7.8474; y = 0.2424; z = -0.0653 }, (* H22  *)
+      { x = 3.4426; y = 5.5361; z = -1.5199 }) (* H8   *)
+      )
+    )
+
+let rG02
+  = N(
+      {    a=0.5566; b=0.0449; c=0.8296; (* dgf_base_tfo *)
+           d=0.5125; e=0.7673; f= -0.3854;
+           g= -0.6538; h=0.6397; i=0.4041;
+           tx= -9.1161; ty= -3.7679; tz= -2.9968 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5'  *)
+      { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5'  *)
+      { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *)
+      { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4'  *)
+      { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4'  *)
+      { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4'  *)
+      { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1'  *)
+      { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1'  *)
+      { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2'  *)
+      { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *)
+      { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2'  *)
+      { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2'  *)
+      { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3'  *)
+      { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3'  *)
+      { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3'  *)
+      { x = 10.3245; y = 8.5459; z = 1.5467 }, (* N1   *)
+      { x = 9.8051; y = 6.9432; z = -0.1497 }, (* N3   *)
+      { x = 10.5175; y = 7.4328; z = 0.8408 }, (* C2   *)
+      { x = 8.7523; y = 7.7422; z = -0.4228 }, (* C4   *)
+      { x = 8.4257; y = 8.9060; z = 0.2099 }, (* C5   *)
+      { x = 9.2665; y = 9.3242; z = 1.2540 }, (* C6 *)
+      (G (
+      { x = 11.6077; y = 6.7966; z = 1.2752 }, (* N2   *)
+      { x = 7.2750; y = 9.4537; z = -0.3428 }, (* N7   *)
+      { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9   *)
+      { x = 6.9479; y = 8.6157; z = -1.2771 }, (* C8   *)
+      { x = 9.0664; y = 10.4462; z = 1.9610 }, (* O6   *)
+      { x = 10.9838; y = 8.7524; z = 2.2697 }, (* H1   *)
+      { x = 12.2274; y = 7.0896; z = 2.0170 }, (* H21  *)
+      { x = 11.8502; y = 5.9398; z = 0.7984 }, (* H22  *)
+      { x = 6.0430; y = 8.9853; z = -1.7594 }) (* H8   *)
+      )
+    )
+
+let rG03
+  = N(
+      {    a= -0.5021; b=0.0731; c=0.8617; (* dgf_base_tfo *)
+           d= -0.8112; e=0.3054; f= -0.4986;
+           g= -0.2996; h= -0.9494; i= -0.0940;
+           tx=6.4273; ty= -5.1944; tz= -3.7807 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5'  *)
+      { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5'  *)
+      { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *)
+      { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4'  *)
+      { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4'  *)
+      { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4'  *)
+      { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1'  *)
+      { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1'  *)
+      { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2'  *)
+      { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *)
+      { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2'  *)
+      { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2'  *)
+      { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3'  *)
+      { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3'  *)
+      { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3'  *)
+      { x = 9.6740; y = 4.7656; z = -7.6614 }, (* N1   *)
+      { x = 9.0739; y = 4.3013; z = -5.3941 }, (* N3   *)
+      { x = 9.8416; y = 4.2192; z = -6.4581 }, (* C2   *)
+      { x = 7.9885; y = 5.0632; z = -5.6446 }, (* C4   *)
+      { x = 7.6822; y = 5.6856; z = -6.8194 }, (* C5   *)
+      { x = 8.5831; y = 5.5215; z = -7.8840 }, (* C6 *)
+      (G (
+      { x = 10.9733; y = 3.5117; z = -6.4286 }, (* N2   *)
+      { x = 6.4857; y = 6.3816; z = -6.7035 }, (* N7   *)
+      { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9   *)
+      { x = 6.1133; y = 6.1613; z = -5.4808 }, (* C8   *)
+      { x = 8.4084; y = 6.0747; z = -9.0933 }, (* O6   *)
+      { x = 10.3759; y = 4.5855; z = -8.3504 }, (* H1   *)
+      { x = 11.6254; y = 3.3761; z = -7.1879 }, (* H21  *)
+      { x = 11.1917; y = 3.0460; z = -5.5593 }, (* H22  *)
+      { x = 5.1705; y = 6.6830; z = -5.3167 }) (* H8   *)
+      )
+    )
+
+let rG04
+  = N(
+      {    a= -0.5426; b= -0.8175; c=0.1929; (* dgf_base_tfo *)
+           d=0.8304; e= -0.5567; f= -0.0237;
+           g=0.1267; h=0.1473; i=0.9809;
+           tx= -0.5075; ty=8.3929; tz=0.2229 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5'  *)
+      { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5'  *)
+      { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *)
+      { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4'  *)
+      { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4'  *)
+      { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4'  *)
+      { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1'  *)
+      { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1'  *)
+      { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2'  *)
+      { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *)
+      { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2'  *)
+      { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2'  *)
+      { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3'  *)
+      { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3'  *)
+      { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3'  *)
+      { x = 3.6343; y = 2.6680; z = 2.0783 }, (* N1   *)
+      { x = 5.4505; y = 3.9805; z = 1.2446 }, (* N3   *)
+      { x = 4.7540; y = 3.3816; z = 2.1851 }, (* C2   *)
+      { x = 4.8805; y = 3.7951; z = 0.0354 }, (* C4   *)
+      { x = 3.7416; y = 3.0925; z = -0.2305 }, (* C5   *)
+      { x = 3.0873; y = 2.4980; z = 0.8606 }, (* C6 *)
+      (G (
+      { x = 5.1433; y = 3.4373; z = 3.4609 }, (* N2   *)
+      { x = 3.4605; y = 3.1184; z = -1.5906 }, (* N7   *)
+      { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9   *)
+      { x = 4.4244; y = 3.8244; z = -2.0953 }, (* C8   *)
+      { x = 1.9600; y = 1.7805; z = 0.7462 }, (* O6   *)
+      { x = 3.2489; y = 2.2879; z = 2.9191 }, (* H1   *)
+      { x = 4.6785; y = 3.0243; z = 4.2568 }, (* H21  *)
+      { x = 5.9823; y = 3.9654; z = 3.6539 }, (* H22  *)
+      { x = 4.2675; y = 3.8876; z = -3.1721 }) (* H8   *)
+      )
+    )
+
+let rG05
+  = N(
+      {    a= -0.5891; b=0.0449; c=0.8068; (* dgf_base_tfo *)
+           d=0.5375; e=0.7673; f=0.3498;
+           g= -0.6034; h=0.6397; i= -0.4762;
+           tx= -0.3019; ty= -3.7679; tz= -9.5913 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5'  *)
+      { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5'  *)
+      { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *)
+      { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4'  *)
+      { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4'  *)
+      { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4'  *)
+      { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1'  *)
+      { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1'  *)
+      { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2'  *)
+      { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *)
+      { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2'  *)
+      { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2'  *)
+      { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3'  *)
+      { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3'  *)
+      { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3'  *)
+      { x = 10.2594; y = 10.6774; z = -1.0056 }, (* N1   *)
+      { x = 9.7528; y = 8.7080; z = -2.2631 }, (* N3   *)
+      { x = 10.4471; y = 9.7876; z = -1.9791 }, (* C2   *)
+      { x = 8.7271; y = 8.5575; z = -1.3991 }, (* C4   *)
+      { x = 8.4100; y = 9.3803; z = -0.3580 }, (* C5   *)
+      { x = 9.2294; y = 10.5030; z = -0.1574 }, (* C6 *)
+      (G (
+      { x = 11.5110; y = 10.1256; z = -2.7114 }, (* N2   *)
+      { x = 7.2891; y = 8.9068; z = 0.3121 }, (* N7   *)
+      { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9   *)
+      { x = 6.9702; y = 7.8292; z = -0.3353 }, (* C8   *)
+      { x = 9.0349; y = 11.3951; z = 0.8250 }, (* O6   *)
+      { x = 10.9013; y = 11.4422; z = -0.9512 }, (* H1   *)
+      { x = 12.1031; y = 10.9341; z = -2.5861 }, (* H21  *)
+      { x = 11.7369; y = 9.5180; z = -3.4859 }, (* H22  *)
+      { x = 6.0888; y = 7.3990; z = 0.1403 }) (* H8   *)
+      )
+    )
+
+let rG06
+  = N(
+      {    a= -0.9815; b=0.0731; c= -0.1772; (* dgf_base_tfo *)
+           d=0.1912; e=0.3054; f= -0.9328;
+           g= -0.0141; h= -0.9494; i= -0.3137;
+           tx=5.7506; ty= -5.1944; tz=4.7470 },
+      {    a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *)
+           d= -0.0433; e= -0.4257; f=0.9038;
+           g= -0.5788; h=0.7480; i=0.3246;
+           tx=1.5227; ty=6.9114; tz= -7.0765 },
+      {    a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *)
+           d=0.4552; e=0.6637; f=0.5935;
+           g= -0.8042; h=0.0203; i=0.5941;
+           tx= -6.9472; ty= -4.1186; tz= -5.9108 },
+      {    a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *)
+           d= -0.8247; e=0.5587; f= -0.0878;
+           g=0.0426; h=0.2162; i=0.9754;
+           tx=6.2694; ty= -7.0540; tz=3.3316 },
+      { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P    *)
+      { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P  *)
+      { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P  *)
+      { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5'  *)
+      { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5'  *)
+      { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5'  *)
+      { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *)
+      { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4'  *)
+      { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4'  *)
+      { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4'  *)
+      { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1'  *)
+      { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1'  *)
+      { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2'  *)
+      { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *)
+      { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2'  *)
+      { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2'  *)
+      { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3'  *)
+      { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3'  *)
+      { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3'  *)
+      { x = 6.6624; y = 3.5061; z = -8.2986 }, (* N1   *)
+      { x = 6.5810; y = 3.2570; z = -5.9221 }, (* N3   *)
+      { x = 6.5151; y = 2.8263; z = -7.1625 }, (* C2   *)
+      { x = 6.8364; y = 4.5817; z = -5.8882 }, (* C4   *)
+      { x = 7.0116; y = 5.4064; z = -6.9609 }, (* C5   *)
+      { x = 6.9173; y = 4.8260; z = -8.2361 }, (* C6 *)
+      (G (
+      { x = 6.2717; y = 1.5402; z = -7.4250 }, (* N2   *)
+      { x = 7.2573; y = 6.7070; z = -6.5394 }, (* N7   *)
+      { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9   *)
+      { x = 7.2238; y = 6.6275; z = -5.2453 }, (* C8   *)
+      { x = 7.0668; y = 5.5163; z = -9.3763 }, (* O6   *)
+      { x = 6.5754; y = 2.9964; z = -9.1545 }, (* H1   *)
+      { x = 6.1908; y = 1.1105; z = -8.3354 }, (* H21  *)
+      { x = 6.1346; y = 0.9352; z = -6.6280 }, (* H22  *)
+      { x = 7.4108; y = 7.6227; z = -4.8418 }) (* H8   *)
+      )
+    )
+
+let rG07
+  = N(
+      {    a=0.0894; b= -0.6059; c=0.7905; (* dgf_base_tfo *)
+           d= -0.6810; e=0.5420; f=0.4924;
+           g= -0.7268; h= -0.5824; i= -0.3642;
+           tx=34.1424; ty=45.9610; tz= -11.8600 },
+      {    a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *)
+           d= -0.0427; e=0.2409; f= -0.9696;
+           g=0.5010; h= -0.8345; i= -0.2294;
+           tx=4.0167; ty=54.5377; tz=12.4779 },
+      {    a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *)
+           d= -0.2867; e= -0.7872; f= -0.5460;
+           g=0.8834; h=0.0032; i= -0.4686;
+           tx= -52.9020; ty=18.6313; tz= -0.6709 },
+      {    a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *)
+           d=0.9040; e= -0.4236; f= -0.0582;
+           g= -0.1007; h= -0.0786; i= -0.9918;
+           tx= -7.6624; ty= -25.2080; tz=49.5181 },
+      { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P    *)
+      { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P  *)
+      { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P  *)
+      { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5'  *)
+      { x = 33.8709; y = 0.7918; z = 47.2113 }, (* C5'  *)
+      { x = 34.1386; y = 0.5870; z = 46.1747 }, (* H5'  *)
+      { x = 34.0186; y = -0.0095; z = 47.9353 }, (* H5'' *)
+      { x = 34.7297; y = 1.9687; z = 47.6685 }, (* C4'  *)
+      { x = 35.7723; y = 1.6845; z = 47.8113 }, (* H4'  *)
+      { x = 34.6455; y = 2.9768; z = 46.6660 }, (* O4'  *)
+      { x = 34.1690; y = 4.1829; z = 47.2627 }, (* C1'  *)
+      { x = 35.0437; y = 4.7633; z = 47.5560 }, (* H1'  *)
+      { x = 33.4145; y = 3.7532; z = 48.4954 }, (* C2'  *)
+      { x = 32.4340; y = 3.3797; z = 48.2001 }, (* H2'' *)
+      { x = 33.3209; y = 4.6953; z = 49.5217 }, (* O2'  *)
+      { x = 33.2374; y = 5.6059; z = 49.2295 }, (* H2'  *)
+      { x = 34.2724; y = 2.5970; z = 48.9773 }, (* C3'  *)
+      { x = 33.6373; y = 1.8935; z = 49.5157 }, (* H3'  *)
+      { x = 35.3453; y = 3.1884; z = 49.7285 }, (* O3'  *)
+      { x = 34.0511; y = 7.8930; z = 43.7791 }, (* N1   *)
+      { x = 34.9937; y = 6.3369; z = 45.3199 }, (* N3   *)
+      { x = 35.0882; y = 7.3126; z = 44.4200 }, (* C2   *)
+      { x = 33.7190; y = 5.9650; z = 45.5374 }, (* C4   *)
+      { x = 32.5845; y = 6.4770; z = 44.9458 }, (* C5   *)
+      { x = 32.7430; y = 7.5179; z = 43.9914 }, (* C6 *)
+      (G (
+      { x = 36.3030; y = 7.7827; z = 44.1036 }, (* N2   *)
+      { x = 31.4499; y = 5.8335; z = 45.4368 }, (* N7   *)
+      { x = 33.2760; y = 4.9817; z = 46.4043 }, (* N9   *)
+      { x = 31.9235; y = 4.9639; z = 46.2934 }, (* C8   *)
+      { x = 31.8602; y = 8.1000; z = 43.3695 }, (* O6   *)
+      { x = 34.2623; y = 8.6223; z = 43.1283 }, (* H1   *)
+      { x = 36.5188; y = 8.5081; z = 43.4347 }, (* H21  *)
+      { x = 37.0888; y = 7.3524; z = 44.5699 }, (* H22  *)
+      { x = 31.0815; y = 4.4201; z = 46.7218 }) (* H8   *)
+      )
+    )
+
+let rG08
+  = N(
+      {    a=0.2224; b=0.6335; c=0.7411; (* dgf_base_tfo *)
+           d= -0.3644; e= -0.6510; f=0.6659;
+           g=0.9043; h= -0.4181; i=0.0861;
+           tx= -47.6824; ty= -0.5823; tz= -31.7554 },
+      {    a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *)
+           d= -0.0427; e=0.2409; f= -0.9696;
+           g=0.5010; h= -0.8345; i= -0.2294;
+           tx=4.0167; ty=54.5377; tz=12.4779 },
+      {    a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *)
+           d= -0.2867; e= -0.7872; f= -0.5460;
+           g=0.8834; h=0.0032; i= -0.4686;
+           tx= -52.9020; ty=18.6313; tz= -0.6709 },
+      {    a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *)
+           d=0.9040; e= -0.4236; f= -0.0582;
+           g= -0.1007; h= -0.0786; i= -0.9918;
+           tx= -7.6624; ty= -25.2080; tz=49.5181 },
+      { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P    *)
+      { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P  *)
+      { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P  *)
+      { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5'  *)
+      { x = 32.5924; y = 2.3488; z = 48.2255 }, (* C5'  *)
+      { x = 33.3674; y = 2.1246; z = 48.9584 }, (* H5'  *)
+      { x = 31.5994; y = 2.5917; z = 48.6037 }, (* H5'' *)
+      { x = 33.0722; y = 3.5577; z = 47.4258 }, (* C4'  *)
+      { x = 33.0310; y = 4.4778; z = 48.0089 }, (* H4'  *)
+      { x = 34.4173; y = 3.3055; z = 47.0316 }, (* O4'  *)
+      { x = 34.5056; y = 3.3910; z = 45.6094 }, (* C1'  *)
+      { x = 34.7881; y = 4.4152; z = 45.3663 }, (* H1'  *)
+      { x = 33.1122; y = 3.1198; z = 45.1010 }, (* C2'  *)
+      { x = 32.9230; y = 2.0469; z = 45.1369 }, (* H2'' *)
+      { x = 32.7946; y = 3.6590; z = 43.8529 }, (* O2'  *)
+      { x = 33.5170; y = 3.6707; z = 43.2207 }, (* H2'  *)
+      { x = 32.2730; y = 3.8173; z = 46.1566 }, (* C3'  *)
+      { x = 31.3094; y = 3.3123; z = 46.2244 }, (* H3'  *)
+      { x = 32.2391; y = 5.2039; z = 45.7807 }, (* O3'  *)
+      { x = 39.3337; y = 2.7157; z = 44.1441 }, (* N1   *)
+      { x = 37.4430; y = 3.8242; z = 45.0824 }, (* N3   *)
+      { x = 38.7276; y = 3.7646; z = 44.7403 }, (* C2   *)
+      { x = 36.7791; y = 2.6963; z = 44.7704 }, (* C4   *)
+      { x = 37.2860; y = 1.5653; z = 44.1678 }, (* C5   *)
+      { x = 38.6647; y = 1.5552; z = 43.8235 }, (* C6 *)
+      (G (
+      { x = 39.5123; y = 4.8216; z = 44.9936 }, (* N2   *)
+      { x = 36.2829; y = 0.6110; z = 44.0078 }, (* N7   *)
+      { x = 35.4394; y = 2.4314; z = 44.9931 }, (* N9   *)
+      { x = 35.2180; y = 1.1815; z = 44.5128 }, (* C8   *)
+      { x = 39.2907; y = 0.6514; z = 43.2796 }, (* O6   *)
+      { x = 40.3076; y = 2.8048; z = 43.9352 }, (* H1   *)
+      { x = 40.4994; y = 4.9066; z = 44.7977 }, (* H21  *)
+      { x = 39.0738; y = 5.6108; z = 45.4464 }, (* H22  *)
+      { x = 34.3856; y = 0.4842; z = 44.4185 }) (* H8   *)
+      )
+    )
+
+let rG09
+  = N(
+      {    a= -0.9699; b= -0.1688; c= -0.1753; (* dgf_base_tfo *)
+           d= -0.1050; e= -0.3598; f=0.9271;
+           g= -0.2196; h=0.9176; i=0.3312;
+           tx=45.6217; ty= -38.9484; tz= -12.3208 },
+      {    a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *)
+           d= -0.0427; e=0.2409; f= -0.9696;
+           g=0.5010; h= -0.8345; i= -0.2294;
+           tx=4.0167; ty=54.5377; tz=12.4779 },
+      {    a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *)
+           d= -0.2867; e= -0.7872; f= -0.5460;
+           g=0.8834; h=0.0032; i= -0.4686;
+           tx= -52.9020; ty=18.6313; tz= -0.6709 },
+      {    a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *)
+           d=0.9040; e= -0.4236; f= -0.0582;
+           g= -0.1007; h= -0.0786; i= -0.9918;
+           tx= -7.6624; ty= -25.2080; tz=49.5181 },
+      { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P    *)
+      { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P  *)
+      { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P  *)
+      { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5'  *)
+      { x = 33.8709; y = 0.7918; z = 47.2113 }, (* C5'  *)
+      { x = 34.1386; y = 0.5870; z = 46.1747 }, (* H5'  *)
+      { x = 34.0186; y = -0.0095; z = 47.9353 }, (* H5'' *)
+      { x = 34.7297; y = 1.9687; z = 47.6685 }, (* C4'  *)
+      { x = 34.5880; y = 2.8482; z = 47.0404 }, (* H4'  *)
+      { x = 34.3575; y = 2.2770; z = 49.0081 }, (* O4'  *)
+      { x = 35.5157; y = 2.1993; z = 49.8389 }, (* C1'  *)
+      { x = 35.9424; y = 3.2010; z = 49.8893 }, (* H1'  *)
+      { x = 36.4701; y = 1.2820; z = 49.1169 }, (* C2'  *)
+      { x = 36.1545; y = 0.2498; z = 49.2683 }, (* H2'' *)
+      { x = 37.8262; y = 1.4547; z = 49.4008 }, (* O2'  *)
+      { x = 38.0227; y = 1.6945; z = 50.3094 }, (* H2'  *)
+      { x = 36.2242; y = 1.6797; z = 47.6725 }, (* C3'  *)
+      { x = 36.4297; y = 0.8197; z = 47.0351 }, (* H3'  *)
+      { x = 37.0289; y = 2.8480; z = 47.4426 }, (* O3'  *)
+      { x = 34.3005; y = 3.5042; z = 54.6070 }, (* N1   *)
+      { x = 34.7693; y = 3.7936; z = 52.2874 }, (* N3   *)
+      { x = 34.4484; y = 4.2541; z = 53.4939 }, (* C2   *)
+      { x = 34.9354; y = 2.4584; z = 52.2785 }, (* C4   *)
+      { x = 34.8092; y = 1.5915; z = 53.3422 }, (* C5   *)
+      { x = 34.4646; y = 2.1367; z = 54.6085 }, (* C6 *)
+      (G (
+      { x = 34.2514; y = 5.5708; z = 53.6503 }, (* N2   *)
+      { x = 35.0641; y = 0.2835; z = 52.9337 }, (* N7   *)
+      { x = 35.2669; y = 1.6690; z = 51.1915 }, (* N9   *)
+      { x = 35.3288; y = 0.3954; z = 51.6563 }, (* C8   *)
+      { x = 34.3151; y = 1.5317; z = 55.6650 }, (* O6   *)
+      { x = 34.0623; y = 3.9797; z = 55.4539 }, (* H1   *)
+      { x = 33.9950; y = 6.0502; z = 54.5016 }, (* H21  *)
+      { x = 34.3512; y = 6.1432; z = 52.8242 }, (* H22  *)
+      { x = 35.5414; y = -0.6006; z = 51.2679 }) (* H8   *)
+      )
+    )
+
+let rG10
+  = N(
+      {    a= -0.0980; b= -0.9723; c=0.2122; (* dgf_base_tfo *)
+           d= -0.9731; e=0.1383; f=0.1841;
+           g= -0.2083; h= -0.1885; i= -0.9597;
+           tx=17.8469; ty=38.8265; tz=37.0475 },
+      {    a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *)
+           d= -0.0427; e=0.2409; f= -0.9696;
+           g=0.5010; h= -0.8345; i= -0.2294;
+           tx=4.0167; ty=54.5377; tz=12.4779 },
+      {    a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *)
+           d= -0.2867; e= -0.7872; f= -0.5460;
+           g=0.8834; h=0.0032; i= -0.4686;
+           tx= -52.9020; ty=18.6313; tz= -0.6709 },
+      {    a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *)
+           d=0.9040; e= -0.4236; f= -0.0582;
+           g= -0.1007; h= -0.0786; i= -0.9918;
+           tx= -7.6624; ty= -25.2080; tz=49.5181 },
+      { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P    *)
+      { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P  *)
+      { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P  *)
+      { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5'  *)
+      { x = 32.5924; y = 2.3488; z = 48.2255 }, (* C5'  *)
+      { x = 33.3674; y = 2.1246; z = 48.9584 }, (* H5'  *)
+      { x = 31.5994; y = 2.5917; z = 48.6037 }, (* H5'' *)
+      { x = 33.0722; y = 3.5577; z = 47.4258 }, (* C4'  *)
+      { x = 34.0333; y = 3.3761; z = 46.9447 }, (* H4'  *)
+      { x = 32.0890; y = 3.8338; z = 46.4332 }, (* O4'  *)
+      { x = 31.6377; y = 5.1787; z = 46.5914 }, (* C1'  *)
+      { x = 32.2499; y = 5.8016; z = 45.9392 }, (* H1'  *)
+      { x = 31.9167; y = 5.5319; z = 48.0305 }, (* C2'  *)
+      { x = 31.1507; y = 5.0820; z = 48.6621 }, (* H2'' *)
+      { x = 32.0865; y = 6.8890; z = 48.3114 }, (* O2'  *)
+      { x = 31.5363; y = 7.4819; z = 47.7942 }, (* H2'  *)
+      { x = 33.2398; y = 4.8224; z = 48.2563 }, (* C3'  *)
+      { x = 33.3166; y = 4.5570; z = 49.3108 }, (* H3'  *)
+      { x = 34.2528; y = 5.7056; z = 47.7476 }, (* O3'  *)
+      { x = 28.2782; y = 6.3049; z = 42.9364 }, (* N1   *)
+      { x = 30.4001; y = 5.8547; z = 43.9258 }, (* N3   *)
+      { x = 29.6195; y = 6.1568; z = 42.8913 }, (* C2   *)
+      { x = 29.7005; y = 5.7006; z = 45.0649 }, (* C4   *)
+      { x = 28.3383; y = 5.8221; z = 45.2343 }, (* C5   *)
+      { x = 27.5519; y = 6.1461; z = 44.0958 }, (* C6 *)
+      (G (
+      { x = 30.1838; y = 6.3385; z = 41.6890 }, (* N2   *)
+      { x = 27.9936; y = 5.5926; z = 46.5651 }, (* N7   *)
+      { x = 30.2046; y = 5.3825; z = 46.3136 }, (* N9   *)
+      { x = 29.1371; y = 5.3398; z = 47.1506 }, (* C8   *)
+      { x = 26.3361; y = 6.3024; z = 44.0495 }, (* O6   *)
+      { x = 27.8122; y = 6.5394; z = 42.0833 }, (* H1   *)
+      { x = 29.7125; y = 6.5595; z = 40.8235 }, (* H21  *)
+      { x = 31.1859; y = 6.2231; z = 41.6389 }, (* H22  *)
+      { x = 28.9406; y = 5.1504; z = 48.2059 }) (* H8   *)
+      )
+    )
+
+let rGs = [rG01;rG02;rG03;rG04;rG05;rG06;rG07;rG08;rG09;rG10]
+
+let rU
+  = N(
+      {    a= -0.0359; b= -0.8071; c=0.5894; (* dgf_base_tfo *)
+           d= -0.2669; e=0.5761; f=0.7726;
+           g= -0.9631; h= -0.1296; i= -0.2361;
+           tx=0.1584; ty=8.3434; tz=0.5434 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5'  *)
+      { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5'  *)
+      { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *)
+      { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4'  *)
+      { x = 7.2954; y = -7.6762; z = 2.4898 }, (* H4'  *)
+      { x = 6.0140; y = -6.5420; z = 1.2890 }, (* O4'  *)
+      { x = 6.4190; y = -5.1840; z = 1.3620 }, (* C1'  *)
+      { x = 7.1608; y = -5.0495; z = 0.5747 }, (* H1'  *)
+      { x = 7.0760; y = -4.9560; z = 2.7270 }, (* C2'  *)
+      { x = 6.7770; y = -3.9803; z = 3.1099 }, (* H2'' *)
+      { x = 8.4500; y = -5.1930; z = 2.5810 }, (* O2'  *)
+      { x = 8.8309; y = -4.8755; z = 1.7590 }, (* H2'  *)
+      { x = 6.4060; y = -6.0590; z = 3.5580 }, (* C3'  *)
+      { x = 5.4021; y = -5.7313; z = 3.8281 }, (* H3'  *)
+      { x = 7.1570; y = -6.4240; z = 4.7070 }, (* O3'  *)
+      { x = 5.2170; y = -4.3260; z = 1.1690 }, (* N1   *)
+      { x = 4.2960; y = -2.2560; z = 0.6290 }, (* N3   *)
+      { x = 5.4330; y = -3.0200; z = 0.7990 }, (* C2   *)
+      { x = 2.9930; y = -2.6780; z = 0.7940 }, (* C4   *)
+      { x = 2.8670; y = -4.0630; z = 1.1830 }, (* C5   *)
+      { x = 3.9570; y = -4.8300; z = 1.3550 }, (* C6 *)
+      (U (
+      { x = 6.5470; y = -2.5560; z = 0.6290 }, (* O2   *)
+      { x = 2.0540; y = -1.9000; z = 0.6130 }, (* O4   *)
+      { x = 4.4300; y = -1.3020; z = 0.3600 }, (* H3   *)
+      { x = 1.9590; y = -4.4570; z = 1.3250 }, (* H5   *)
+      { x = 3.8460; y = -5.7860; z = 1.6240 }) (* H6   *)
+      )
+    )
+
+let rU01
+  = N(
+      {    a= -0.0137; b= -0.8012; c=0.5983; (* dgf_base_tfo *)
+           d= -0.2523; e=0.5817; f=0.7733;
+           g= -0.9675; h= -0.1404; i= -0.2101;
+           tx=0.2031; ty=8.3874; tz=0.4228 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5'  *)
+      { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5'  *)
+      { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *)
+      { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4'  *)
+      { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4'  *)
+      { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4'  *)
+      { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1'  *)
+      { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1'  *)
+      { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2'  *)
+      { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *)
+      { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2'  *)
+      { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2'  *)
+      { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3'  *)
+      { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3'  *)
+      { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3'  *)
+      { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1   *)
+      { x = 4.3777; y = -2.2062; z = 0.7229 }, (* N3   *)
+      { x = 5.5069; y = -2.9779; z = 0.9088 }, (* C2   *)
+      { x = 3.0693; y = -2.6246; z = 0.8500 }, (* C4   *)
+      { x = 2.9279; y = -4.0146; z = 1.2149 }, (* C5   *)
+      { x = 4.0101; y = -4.7892; z = 1.4017 }, (* C6 *)
+      (U (
+      { x = 6.6267; y = -2.5166; z = 0.7728 }, (* O2   *)
+      { x = 2.1383; y = -1.8396; z = 0.6581 }, (* O4   *)
+      { x = 4.5223; y = -1.2489; z = 0.4716 }, (* H3   *)
+      { x = 2.0151; y = -4.4065; z = 1.3290 }, (* H5   *)
+      { x = 3.8886; y = -5.7486; z = 1.6535 }) (* H6   *)
+      )
+    )
+
+let rU02
+  = N(
+      {    a=0.5141; b=0.0246; c=0.8574; (* dgf_base_tfo *)
+           d= -0.5547; e= -0.7529; f=0.3542;
+           g=0.6542; h= -0.6577; i= -0.3734;
+           tx= -9.1111; ty= -3.4598; tz= -3.2939 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5'  *)
+      { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5'  *)
+      { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *)
+      { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4'  *)
+      { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4'  *)
+      { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4'  *)
+      { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1'  *)
+      { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1'  *)
+      { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2'  *)
+      { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *)
+      { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2'  *)
+      { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2'  *)
+      { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3'  *)
+      { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3'  *)
+      { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3'  *)
+      { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1   *)
+      { x = 8.6945; y = -8.7046; z = -0.2857 }, (* N3   *)
+      { x = 8.6943; y = -7.6514; z = 0.6066 }, (* C2   *)
+      { x = 7.7426; y = -9.6987; z = -0.3801 }, (* C4   *)
+      { x = 6.6642; y = -9.5742; z = 0.5722 }, (* C5   *)
+      { x = 6.6391; y = -8.5592; z = 1.4526 }, (* C6 *)
+      (U (
+      { x = 9.5840; y = -6.8186; z = 0.6136 }, (* O2   *)
+      { x = 7.8505; y = -10.5925; z = -1.2223 }, (* O4   *)
+      { x = 9.4601; y = -8.7514; z = -0.9277 }, (* H3   *)
+      { x = 5.9281; y = -10.2509; z = 0.5782 }, (* H5   *)
+      { x = 5.8831; y = -8.4931; z = 2.1028 }) (* H6   *)
+      )
+    )
+
+let rU03
+  = N(
+      {    a= -0.4993; b=0.0476; c=0.8651; (* dgf_base_tfo *)
+           d=0.8078; e= -0.3353; f=0.4847;
+           g=0.3132; h=0.9409; i=0.1290;
+           tx=6.2989; ty= -5.2303; tz= -3.8577 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5'  *)
+      { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5'  *)
+      { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *)
+      { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4'  *)
+      { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4'  *)
+      { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4'  *)
+      { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1'  *)
+      { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1'  *)
+      { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2'  *)
+      { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *)
+      { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2'  *)
+      { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2'  *)
+      { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3'  *)
+      { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3'  *)
+      { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3'  *)
+      { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1   *)
+      { x = 7.9218; y = -5.5700; z = 6.8877 }, (* N3   *)
+      { x = 7.8908; y = -5.0886; z = 5.5944 }, (* C2   *)
+      { x = 6.9789; y = -6.3827; z = 7.4823 }, (* C4   *)
+      { x = 5.8742; y = -6.7319; z = 6.6202 }, (* C5   *)
+      { x = 5.8182; y = -6.2769; z = 5.3570 }, (* C6 *)
+      (U (
+      { x = 8.7747; y = -4.3728; z = 5.1568 }, (* O2   *)
+      { x = 7.1154; y = -6.7509; z = 8.6509 }, (* O4   *)
+      { x = 8.7055; y = -5.3037; z = 7.4491 }, (* H3   *)
+      { x = 5.1416; y = -7.3178; z = 6.9665 }, (* H5   *)
+      { x = 5.0441; y = -6.5310; z = 4.7784 }) (* H6   *)
+      )
+    )
+
+let rU04
+  = N(
+      {    a= -0.5669; b= -0.8012; c=0.1918; (* dgf_base_tfo *)
+           d= -0.8129; e=0.5817; f=0.0273;
+           g= -0.1334; h= -0.1404; i= -0.9811;
+           tx= -0.3279; ty=8.3874; tz=0.3355 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5'  *)
+      { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5'  *)
+      { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *)
+      { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4'  *)
+      { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4'  *)
+      { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4'  *)
+      { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1'  *)
+      { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1'  *)
+      { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2'  *)
+      { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *)
+      { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2'  *)
+      { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2'  *)
+      { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3'  *)
+      { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3'  *)
+      { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3'  *)
+      { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1   *)
+      { x = 3.8961; y = -3.0896; z = -0.1893 }, (* N3   *)
+      { x = 5.0095; y = -3.8907; z = -0.0346 }, (* C2   *)
+      { x = 3.0480; y = -2.6632; z = 0.8116 }, (* C4   *)
+      { x = 3.4093; y = -3.1310; z = 2.1292 }, (* C5   *)
+      { x = 4.4878; y = -3.9124; z = 2.3088 }, (* C6 *)
+      (U (
+      { x = 5.7005; y = -4.2164; z = -0.9842 }, (* O2   *)
+      { x = 2.0800; y = -1.9458; z = 0.5503 }, (* O4   *)
+      { x = 3.6834; y = -2.7882; z = -1.1190 }, (* H3   *)
+      { x = 2.8508; y = -2.8721; z = 2.9172 }, (* H5   *)
+      { x = 4.7188; y = -4.2247; z = 3.2295 }) (* H6   *)
+      )
+    )
+
+let rU05
+  = N(
+      {    a= -0.6298; b=0.0246; c=0.7763; (* dgf_base_tfo *)
+           d= -0.5226; e= -0.7529; f= -0.4001;
+           g=0.5746; h= -0.6577; i=0.4870;
+           tx= -0.0208; ty= -3.4598; tz= -9.6882 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5'  *)
+      { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5'  *)
+      { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *)
+      { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4'  *)
+      { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4'  *)
+      { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4'  *)
+      { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1'  *)
+      { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1'  *)
+      { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2'  *)
+      { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *)
+      { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2'  *)
+      { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2'  *)
+      { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3'  *)
+      { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3'  *)
+      { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3'  *)
+      { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1   *)
+      { x = 8.5977; y = -9.5977; z = 0.7329 }, (* N3   *)
+      { x = 8.5951; y = -8.5745; z = 1.6594 }, (* C2   *)
+      { x = 7.7372; y = -9.7371; z = -0.3364 }, (* C4   *)
+      { x = 6.7596; y = -8.6801; z = -0.4476 }, (* C5   *)
+      { x = 6.7338; y = -7.6721; z = 0.4408 }, (* C6 *)
+      (U (
+      { x = 9.3993; y = -8.5377; z = 2.5743 }, (* O2   *)
+      { x = 7.8374; y = -10.6990; z = -1.1008 }, (* O4   *)
+      { x = 9.2924; y = -10.3081; z = 0.8477 }, (* H3   *)
+      { x = 6.0932; y = -8.6982; z = -1.1929 }, (* H5   *)
+      { x = 6.0481; y = -6.9515; z = 0.3446 }) (* H6   *)
+      )
+    )
+
+let rU06
+  = N(
+      {    a= -0.9837; b=0.0476; c= -0.1733; (* dgf_base_tfo *)
+           d= -0.1792; e= -0.3353; f=0.9249;
+           g= -0.0141; h=0.9409; i=0.3384;
+           tx=5.7793; ty= -5.2303; tz=4.5997 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5'  *)
+      { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5'  *)
+      { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *)
+      { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4'  *)
+      { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4'  *)
+      { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4'  *)
+      { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1'  *)
+      { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1'  *)
+      { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2'  *)
+      { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *)
+      { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2'  *)
+      { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2'  *)
+      { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3'  *)
+      { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3'  *)
+      { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3'  *)
+      { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1   *)
+      { x = 6.6920; y = -5.0495; z = 7.1354 }, (* N3   *)
+      { x = 6.6201; y = -4.5500; z = 5.8506 }, (* C2   *)
+      { x = 6.9254; y = -6.3614; z = 7.4926 }, (* C4   *)
+      { x = 7.1046; y = -7.2543; z = 6.3718 }, (* C5   *)
+      { x = 7.0391; y = -6.7951; z = 5.1106 }, (* C6 *)
+      (U (
+      { x = 6.4083; y = -3.3696; z = 5.6340 }, (* O2   *)
+      { x = 6.9679; y = -6.6901; z = 8.6800 }, (* O4   *)
+      { x = 6.5626; y = -4.3957; z = 7.8812 }, (* H3   *)
+      { x = 7.2781; y = -8.2254; z = 6.5350 }, (* H5   *)
+      { x = 7.1657; y = -7.4312; z = 4.3503 }) (* H6   *)
+      )
+    )
+
+let rU07
+  = N(
+      {    a= -0.9434; b=0.3172; c=0.0971; (* dgf_base_tfo *)
+           d=0.2294; e=0.4125; f=0.8816;
+           g=0.2396; h=0.8539; i= -0.4619;
+           tx=8.3625; ty= -52.7147; tz=1.3745 },
+      {    a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *)
+           d= -0.8297; e=0.4733; f= -0.2959;
+           g=0.4850; h=0.8737; i=0.0379;
+           tx= -14.7774; ty= -45.2464; tz=21.9088 },
+      {    a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *)
+           d= -0.5932; e= -0.6591; f=0.4624;
+           g= -0.7980; h=0.4055; i= -0.4458;
+           tx=43.7634; ty=4.3296; tz=28.4890 },
+      {    a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *)
+           d=0.6803; e=0.3317; f=0.6536;
+           g= -0.1673; h= -0.7979; i=0.5791;
+           tx= -17.1858; ty=41.4390; tz= -27.0751 },
+      { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P    *)
+      { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P  *)
+      { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P  *)
+      { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5'  *)
+      { x = 21.5037; y = 16.8594; z = 43.7323 }, (* C5'  *)
+      { x = 20.8147; y = 17.6663; z = 43.9823 }, (* H5'  *)
+      { x = 21.1086; y = 16.0230; z = 43.1557 }, (* H5'' *)
+      { x = 22.5654; y = 17.4874; z = 42.8616 }, (* C4'  *)
+      { x = 22.1584; y = 17.7243; z = 41.8785 }, (* H4'  *)
+      { x = 23.0557; y = 18.6826; z = 43.4751 }, (* O4'  *)
+      { x = 24.4788; y = 18.6151; z = 43.6455 }, (* C1'  *)
+      { x = 24.9355; y = 19.0840; z = 42.7739 }, (* H1'  *)
+      { x = 24.7958; y = 17.1427; z = 43.6474 }, (* C2'  *)
+      { x = 24.5652; y = 16.7400; z = 44.6336 }, (* H2'' *)
+      { x = 26.1041; y = 16.8773; z = 43.2455 }, (* O2'  *)
+      { x = 26.7516; y = 17.5328; z = 43.5149 }, (* H2'  *)
+      { x = 23.8109; y = 16.5979; z = 42.6377 }, (* C3'  *)
+      { x = 23.5756; y = 15.5686; z = 42.9084 }, (* H3'  *)
+      { x = 24.2890; y = 16.7447; z = 41.2729 }, (* O3'  *)
+      { x = 24.9420; y = 19.2174; z = 44.8923 }, (* N1   *)
+      { x = 25.2655; y = 20.5636; z = 44.8883 }, (* N3   *)
+      { x = 25.1663; y = 21.2219; z = 43.8561 }, (* C2   *)
+      { x = 25.6911; y = 21.1219; z = 46.0494 }, (* C4   *)
+      { x = 25.8051; y = 20.4068; z = 47.2048 }, (* C5   *)
+      { x = 26.2093; y = 20.9962; z = 48.2534 }, (* C6 *)
+      (U (
+      { x = 25.4692; y = 19.0221; z = 47.2053 }, (* O2   *)
+      { x = 25.0502; y = 18.4827; z = 46.0370 }, (* O4   *)
+      { x = 25.9599; y = 22.1772; z = 46.0966 }, (* H3   *)
+      { x = 25.5545; y = 18.4409; z = 48.1234 }, (* H5   *)
+      { x = 24.7854; y = 17.4265; z = 45.9883 }) (* H6   *)
+      )
+    )
+
+let rU08
+  = N(
+      {    a= -0.0080; b= -0.7928; c=0.6094; (* dgf_base_tfo *)
+           d= -0.7512; e=0.4071; f=0.5197;
+           g= -0.6601; h= -0.4536; i= -0.5988;
+           tx=44.1482; ty=30.7036; tz=2.1088 },
+      {    a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *)
+           d= -0.8297; e=0.4733; f= -0.2959;
+           g=0.4850; h=0.8737; i=0.0379;
+           tx= -14.7774; ty= -45.2464; tz=21.9088 },
+      {    a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *)
+           d= -0.5932; e= -0.6591; f=0.4624;
+           g= -0.7980; h=0.4055; i= -0.4458;
+           tx=43.7634; ty=4.3296; tz=28.4890 },
+      {    a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *)
+           d=0.6803; e=0.3317; f=0.6536;
+           g= -0.1673; h= -0.7979; i=0.5791;
+           tx= -17.1858; ty=41.4390; tz= -27.0751 },
+      { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P    *)
+      { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P  *)
+      { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P  *)
+      { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5'  *)
+      { x = 23.5096; y = 16.1227; z = 44.5783 }, (* C5'  *)
+      { x = 23.5649; y = 15.8588; z = 43.5222 }, (* H5'  *)
+      { x = 23.9621; y = 15.4341; z = 45.2919 }, (* H5'' *)
+      { x = 24.2805; y = 17.4138; z = 44.7151 }, (* C4'  *)
+      { x = 25.3492; y = 17.2309; z = 44.6030 }, (* H4'  *)
+      { x = 23.8497; y = 18.3471; z = 43.7208 }, (* O4'  *)
+      { x = 23.4090; y = 19.5681; z = 44.3321 }, (* C1'  *)
+      { x = 24.2595; y = 20.2496; z = 44.3524 }, (* H1'  *)
+      { x = 23.0418; y = 19.1813; z = 45.7407 }, (* C2'  *)
+      { x = 22.0532; y = 18.7224; z = 45.7273 }, (* H2'' *)
+      { x = 23.1307; y = 20.2521; z = 46.6291 }, (* O2'  *)
+      { x = 22.8888; y = 21.1051; z = 46.2611 }, (* H2'  *)
+      { x = 24.0799; y = 18.1326; z = 46.0700 }, (* C3'  *)
+      { x = 23.6490; y = 17.4370; z = 46.7900 }, (* H3'  *)
+      { x = 25.3329; y = 18.7227; z = 46.5109 }, (* O3'  *)
+      { x = 22.2515; y = 20.1624; z = 43.6698 }, (* N1   *)
+      { x = 22.4760; y = 21.0609; z = 42.6406 }, (* N3   *)
+      { x = 23.6229; y = 21.3462; z = 42.3061 }, (* C2   *)
+      { x = 21.3986; y = 21.6081; z = 42.0236 }, (* C4   *)
+      { x = 20.1189; y = 21.3012; z = 42.3804 }, (* C5   *)
+      { x = 19.1599; y = 21.8516; z = 41.7578 }, (* C6 *)
+      (U (
+      { x = 19.8919; y = 20.3745; z = 43.4387 }, (* O2   *)
+      { x = 20.9790; y = 19.8423; z = 44.0440 }, (* O4   *)
+      { x = 21.5235; y = 22.3222; z = 41.2097 }, (* H3   *)
+      { x = 18.8732; y = 20.1200; z = 43.7312 }, (* H5   *)
+      { x = 20.8545; y = 19.1313; z = 44.8608 }) (* H6   *)
+      )
+    )
+
+let rU09
+  = N(
+      {    a= -0.0317; b=0.1374; c=0.9900; (* dgf_base_tfo *)
+           d= -0.3422; e= -0.9321; f=0.1184;
+           g=0.9391; h= -0.3351; i=0.0765;
+           tx= -32.1929; ty=25.8198; tz= -28.5088 },
+      {    a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *)
+           d= -0.8297; e=0.4733; f= -0.2959;
+           g=0.4850; h=0.8737; i=0.0379;
+           tx= -14.7774; ty= -45.2464; tz=21.9088 },
+      {    a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *)
+           d= -0.5932; e= -0.6591; f=0.4624;
+           g= -0.7980; h=0.4055; i= -0.4458;
+           tx=43.7634; ty=4.3296; tz=28.4890 },
+      {    a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *)
+           d=0.6803; e=0.3317; f=0.6536;
+           g= -0.1673; h= -0.7979; i=0.5791;
+           tx= -17.1858; ty=41.4390; tz= -27.0751 },
+      { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P    *)
+      { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P  *)
+      { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P  *)
+      { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5'  *)
+      { x = 21.5037; y = 16.8594; z = 43.7323 }, (* C5'  *)
+      { x = 20.8147; y = 17.6663; z = 43.9823 }, (* H5'  *)
+      { x = 21.1086; y = 16.0230; z = 43.1557 }, (* H5'' *)
+      { x = 22.5654; y = 17.4874; z = 42.8616 }, (* C4'  *)
+      { x = 23.0565; y = 18.3036; z = 43.3915 }, (* H4'  *)
+      { x = 23.5375; y = 16.5054; z = 42.4925 }, (* O4'  *)
+      { x = 23.6574; y = 16.4257; z = 41.0649 }, (* C1'  *)
+      { x = 24.4701; y = 17.0882; z = 40.7671 }, (* H1'  *)
+      { x = 22.3525; y = 16.9643; z = 40.5396 }, (* C2'  *)
+      { x = 21.5993; y = 16.1799; z = 40.6133 }, (* H2'' *)
+      { x = 22.4693; y = 17.4849; z = 39.2515 }, (* O2'  *)
+      { x = 23.0899; y = 17.0235; z = 38.6827 }, (* H2'  *)
+      { x = 22.0341; y = 18.0633; z = 41.5279 }, (* C3'  *)
+      { x = 20.9509; y = 18.1709; z = 41.5846 }, (* H3'  *)
+      { x = 22.7249; y = 19.3020; z = 41.2100 }, (* O3'  *)
+      { x = 23.8580; y = 15.0648; z = 40.5757 }, (* N1   *)
+      { x = 25.1556; y = 14.5982; z = 40.4523 }, (* N3   *)
+      { x = 26.1047; y = 15.3210; z = 40.7448 }, (* C2   *)
+      { x = 25.3391; y = 13.3315; z = 40.0020 }, (* C4   *)
+      { x = 24.2974; y = 12.5148; z = 39.6749 }, (* C5   *)
+      { x = 24.5450; y = 11.3410; z = 39.2610 }, (* C6 *)
+      (U (
+      { x = 22.9633; y = 12.9979; z = 39.8053 }, (* O2   *)
+      { x = 22.8009; y = 14.2648; z = 40.2524 }, (* O4   *)
+      { x = 26.3414; y = 12.9194; z = 39.8855 }, (* H3   *)
+      { x = 22.1227; y = 12.3533; z = 39.5486 }, (* H5   *)
+      { x = 21.7989; y = 14.6788; z = 40.3650 }) (* H6   *)
+      )
+    )
+
+let rU10
+  = N(
+      {    a= -0.9674; b=0.1021; c= -0.2318; (* dgf_base_tfo *)
+           d= -0.2514; e= -0.2766; f=0.9275;
+           g=0.0306; h=0.9555; i=0.2933;
+           tx=27.8571; ty= -42.1305; tz= -24.4563 },
+      {    a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *)
+           d= -0.8297; e=0.4733; f= -0.2959;
+           g=0.4850; h=0.8737; i=0.0379;
+           tx= -14.7774; ty= -45.2464; tz=21.9088 },
+      {    a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *)
+           d= -0.5932; e= -0.6591; f=0.4624;
+           g= -0.7980; h=0.4055; i= -0.4458;
+           tx=43.7634; ty=4.3296; tz=28.4890 },
+      {    a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *)
+           d=0.6803; e=0.3317; f=0.6536;
+           g= -0.1673; h= -0.7979; i=0.5791;
+           tx= -17.1858; ty=41.4390; tz= -27.0751 },
+      { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P    *)
+      { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P  *)
+      { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P  *)
+      { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5'  *)
+      { x = 23.5096; y = 16.1227; z = 44.5783 }, (* C5'  *)
+      { x = 23.5649; y = 15.8588; z = 43.5222 }, (* H5'  *)
+      { x = 23.9621; y = 15.4341; z = 45.2919 }, (* H5'' *)
+      { x = 24.2805; y = 17.4138; z = 44.7151 }, (* C4'  *)
+      { x = 23.8509; y = 18.1819; z = 44.0720 }, (* H4'  *)
+      { x = 24.2506; y = 17.8583; z = 46.0741 }, (* O4'  *)
+      { x = 25.5830; y = 18.0320; z = 46.5775 }, (* C1'  *)
+      { x = 25.8569; y = 19.0761; z = 46.4256 }, (* H1'  *)
+      { x = 26.4410; y = 17.1555; z = 45.7033 }, (* C2'  *)
+      { x = 26.3459; y = 16.1253; z = 46.0462 }, (* H2'' *)
+      { x = 27.7649; y = 17.5888; z = 45.6478 }, (* O2'  *)
+      { x = 28.1004; y = 17.9719; z = 46.4616 }, (* H2'  *)
+      { x = 25.7796; y = 17.2997; z = 44.3513 }, (* C3'  *)
+      { x = 25.9478; y = 16.3824; z = 43.7871 }, (* H3'  *)
+      { x = 26.2154; y = 18.4984; z = 43.6541 }, (* O3'  *)
+      { x = 25.7321; y = 17.6281; z = 47.9726 }, (* N1   *)
+      { x = 25.5136; y = 18.5779; z = 48.9560 }, (* N3   *)
+      { x = 25.2079; y = 19.7276; z = 48.6503 }, (* C2   *)
+      { x = 25.6482; y = 18.1987; z = 50.2518 }, (* C4   *)
+      { x = 25.9847; y = 16.9266; z = 50.6092 }, (* C5   *)
+      { x = 26.0918; y = 16.6439; z = 51.8416 }, (* C6 *)
+      (U (
+      { x = 26.2067; y = 15.9515; z = 49.5943 }, (* O2   *)
+      { x = 26.0713; y = 16.3497; z = 48.3080 }, (* O4   *)
+      { x = 25.4890; y = 18.9105; z = 51.0618 }, (* H3   *)
+      { x = 26.4742; y = 14.9310; z = 49.8682 }, (* H5   *)
+      { x = 26.2346; y = 15.6394; z = 47.4975 }) (* H6   *)
+      )
+    )
+
+let rUs = [rU01;rU02;rU03;rU04;rU05;rU06;rU07;rU08;rU09;rU10]
+
+let rG'
+  = N(
+      {    a= -0.2067; b= -0.0264; c=0.9780; (* dgf_base_tfo *)
+           d=0.9770; e= -0.0586; f=0.2049;
+           g=0.0519; h=0.9979; i=0.0379;
+           tx=1.0331; ty= -46.8078; tz= -36.4742 },
+      {    a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *)
+           d= -0.0427; e=0.2409; f= -0.9696;
+           g=0.5010; h= -0.8345; i= -0.2294;
+           tx=4.0167; ty=54.5377; tz=12.4779 },
+      {    a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *)
+           d= -0.2867; e= -0.7872; f= -0.5460;
+           g=0.8834; h=0.0032; i= -0.4686;
+           tx= -52.9020; ty=18.6313; tz= -0.6709 },
+      {    a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *)
+           d=0.9040; e= -0.4236; f= -0.0582;
+           g= -0.1007; h= -0.0786; i= -0.9918;
+           tx= -7.6624; ty= -25.2080; tz=49.5181 },
+      { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P    *)
+      { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P  *)
+      { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P  *)
+      { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5'  *)
+      { x = 32.1610; y = 2.2370; z = 46.2560 }, (* C5'  *)
+      { x = 31.2986; y = 2.8190; z = 46.5812 }, (* H5'  *)
+      { x = 32.0980; y = 1.7468; z = 45.2845 }, (* H5'' *)
+      { x = 33.3476; y = 3.1959; z = 46.1947 }, (* C4'  *)
+      { x = 33.2668; y = 3.8958; z = 45.3630 }, (* H4'  *)
+      { x = 33.3799; y = 3.9183; z = 47.4216 }, (* O4'  *)
+      { x = 34.6515; y = 3.7222; z = 48.0398 }, (* C1'  *)
+      { x = 35.2947; y = 4.5412; z = 47.7180 }, (* H1'  *)
+      { x = 35.1756; y = 2.4228; z = 47.4827 }, (* C2'  *)
+      { x = 34.6778; y = 1.5937; z = 47.9856 }, (* H2'' *)
+      { x = 36.5631; y = 2.2672; z = 47.4798 }, (* O2'  *)
+      { x = 37.0163; y = 2.6579; z = 48.2305 }, (* H2'  *)
+      { x = 34.6953; y = 2.5043; z = 46.0448 }, (* C3'  *)
+      { x = 34.5444; y = 1.4917; z = 45.6706 }, (* H3'  *)
+      { x = 35.6679; y = 3.3009; z = 45.3487 }, (* O3'  *)
+      { x = 37.4804; y = 4.0914; z = 52.2559 }, (* N1   *)
+      { x = 36.9670; y = 4.1312; z = 49.9281 }, (* N3   *)
+      { x = 37.8045; y = 4.2519; z = 50.9550 }, (* C2   *)
+      { x = 35.7171; y = 3.8264; z = 50.3222 }, (* C4   *)
+      { x = 35.2668; y = 3.6420; z = 51.6115 }, (* C5   *)
+      { x = 36.2037; y = 3.7829; z = 52.6706 }, (* C6 *)
+      (G (
+      { x = 39.0869; y = 4.5552; z = 50.7092 }, (* N2   *)
+      { x = 33.9075; y = 3.3338; z = 51.6102 }, (* N7   *)
+      { x = 34.6126; y = 3.6358; z = 49.5108 }, (* N9   *)
+      { x = 33.5805; y = 3.3442; z = 50.3425 }, (* C8   *)
+      { x = 35.9958; y = 3.6512; z = 53.8724 }, (* O6   *)
+      { x = 38.2106; y = 4.2053; z = 52.9295 }, (* H1   *)
+      { x = 39.8218; y = 4.6863; z = 51.3896 }, (* H21  *)
+      { x = 39.3420; y = 4.6857; z = 49.7407 }, (* H22  *)
+      { x = 32.5194; y = 3.1070; z = 50.2664 }) (* H8   *)
+      )
+    )
+
+let rU'
+  = N(
+      {    a= -0.0109; b=0.5907; c=0.8068; (* dgf_base_tfo *)
+           d=0.2217; e= -0.7853; f=0.5780;
+           g=0.9751; h=0.1852; i= -0.1224;
+           tx= -1.4225; ty= -11.0956; tz= -2.5217 },
+      {    a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *)
+           d=0.0649; e=0.4366; f= -0.8973;
+           g=0.5521; h= -0.7648; i= -0.3322;
+           tx=1.6833; ty=6.8060; tz= -7.0011 },
+      {    a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *)
+           d= -0.4628; e= -0.6450; f= -0.6082;
+           g=0.8168; h= -0.0436; i= -0.5753;
+           tx= -6.8179; ty= -3.9778; tz= -5.9887 },
+      {    a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *)
+           d=0.8103; e= -0.5790; f=0.0906;
+           g= -0.0255; h= -0.1894; i= -0.9816;
+           tx=6.1203; ty= -7.1051; tz=3.1984 },
+      { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P    *)
+      { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P  *)
+      { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P  *)
+      { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5'  *)
+      { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5'  *)
+      { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5'  *)
+      { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *)
+      { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4'  *)
+      { x = 5.8744; y = -6.2116; z = 2.4731 }, (* H4'  *)
+      { x = 7.2798; y = -7.2260; z = 3.6420 }, (* O4'  *)
+      { x = 8.5733; y = -6.9410; z = 3.1329 }, (* C1'  *)
+      { x = 8.9047; y = -6.0374; z = 3.6446 }, (* H1'  *)
+      { x = 8.4429; y = -6.6596; z = 1.6327 }, (* C2'  *)
+      { x = 9.2880; y = -7.1071; z = 1.1096 }, (* H2'' *)
+      { x = 8.2502; y = -5.2799; z = 1.4754 }, (* O2'  *)
+      { x = 8.7676; y = -4.7284; z = 2.0667 }, (* H2'  *)
+      { x = 7.1642; y = -7.4416; z = 1.3021 }, (* C3'  *)
+      { x = 7.4125; y = -8.5002; z = 1.2260 }, (* H3'  *)
+      { x = 6.5160; y = -6.9772; z = 0.1267 }, (* O3'  *)
+      { x = 9.4531; y = -8.1107; z = 3.4087 }, (* N1   *)
+      { x = 11.5931; y = -9.0015; z = 3.6357 }, (* N3   *)
+      { x = 10.8101; y = -7.8950; z = 3.3748 }, (* C2   *)
+      { x = 11.1439; y = -10.2744; z = 3.9206 }, (* C4   *)
+      { x = 9.7056; y = -10.4026; z = 3.9332 }, (* C5   *)
+      { x = 8.9192; y = -9.3419; z = 3.6833 }, (* C6 *)
+      (U (
+      { x = 11.3013; y = -6.8063; z = 3.1326 }, (* O2   *)
+      { x = 11.9431; y = -11.1876; z = 4.1375 }, (* O4   *)
+      { x = 12.5840; y = -8.8673; z = 3.6158 }, (* H3   *)
+      { x = 9.2891; y = -11.2898; z = 4.1313 }, (* H5   *)
+      { x = 7.9263; y = -9.4537; z = 3.6977 }) (* H6   *)
+      )
+    )
+
+(* -- PARTIAL INSTANTIATIONS ------------------------------------------------*)
+
+type variable =
+  { id : int;
+    t : tfo;
+    n : nuc }
+
+let mk_var i t n = { id = i; t = t; n = n }
+
+let absolute_pos v p = tfo_apply v.t p
+
+let atom_pos atom v = absolute_pos v (atom v.n)
+
+let rec get_var id = function
+ | (v::lst) -> if id = v.id then v else get_var id lst
+ | _ -> assert false
+
+(* -- SEARCH ----------------------------------------------------------------*)
+
+(* Sequential backtracking algorithm *)
+
+let rec search (partial_inst : variable list) l constr =
+  match l with
+    [] -> [partial_inst]
+  | (h::t) ->
+      let rec try_assignments = function
+        [] -> []
+      | v::vs ->
+          if constr v partial_inst then
+            (search (v::partial_inst) t constr) @ (try_assignments vs)
+          else
+            try_assignments vs
+      in
+        try_assignments (h partial_inst)
+
+
+(* -- DOMAINS ---------------------------------------------------------------*)
+
+(* Primary structure:   strand A CUGCCACGUCUG, strand B CAGACGUGGCAG
+  
+   Secondary structure: strand A CUGCCACGUCUG
+                                 ||||||||||||
+                                 GACGGUGCAGAC strand B
+  
+   Tertiary structure:
+  
+      5' end of strand A C1----G12 3' end of strand B
+                       U2-------A11
+                      G3-------C10
+                      C4-----G9
+                       C5---G8
+                          A6
+                        G6-C7
+                       C5----G8
+                      A4-------U9
+                      G3--------C10
+                       A2-------U11
+     5' end of strand B C1----G12 3' end of strand A
+  
+   "helix", "stacked" and "connected" describe the spatial relationship
+   between two consecutive nucleotides. E.g. the nucleotides C1 and U2
+   from the strand A.
+  
+   "wc" (stands for Watson-Crick and is a type of base-pairing),
+   and "wc-dumas" describe the spatial relationship between 
+   nucleotides from two chains that are growing in opposite directions.
+   E.g. the nucleotides C1 from strand A and G12 from strand B.
+*)
+
+(* Dynamic Domains *)
+
+(* Given,
+     "refnuc" a nucleotide which is already positioned,
+     "nucl" the nucleotide to be placed,
+     and "tfo" a transformation matrix which expresses the desired
+     relationship between "refnuc" and "nucl",
+   the function "dgf-base" computes the transformation matrix that
+   places the nucleotide "nucl" in the given relationship to "refnuc".
+*)
+
+let
+dgf_base tfo v nucl
+  = let x = if is_A v.n then
+                tfo_align (atom_pos nuc_C1' v)
+                          (atom_pos rA_N9   v)
+                          (atom_pos nuc_C4  v)
+              else if is_C v.n then
+                tfo_align (atom_pos nuc_C1' v)
+                          (atom_pos nuc_N1  v)
+                          (atom_pos nuc_C2  v)
+              else if is_G v.n then
+                tfo_align (atom_pos nuc_C1' v)
+                          (atom_pos rG_N9   v)
+                          (atom_pos nuc_C4  v)
+              else
+                tfo_align (atom_pos nuc_C1' v)
+                          (atom_pos nuc_N1  v)
+                          (atom_pos nuc_C2  v)
+    in
+      tfo_combine (nuc_dgf_base_tfo nucl)
+                  (tfo_combine tfo (tfo_inv_ortho x))
+
+(* Placement of first nucleotide. *)
+
+let
+reference n i partial_inst = [ mk_var i tfo_id n ]
+
+(* The transformation matrix for wc is from:
+  
+   Chandrasekaran R. et al (1989) A Re-Examination of the Crystal
+   Structure of A-DNA Using Fiber Diffraction Data. J. Biomol.
+   Struct. & Dynamics 6(6):1189-1202.
+*)
+
+let wc_tfo
+  = (
+      {    a= -1.0000; b=0.0028; c= -0.0019;
+           d=0.0028; e=0.3468; f= -0.9379;
+           g= -0.0019; h= -0.9379; i= -0.3468;
+           tx= -0.0080; ty=6.0730; tz=8.7208 }
+    )
+
+let
+wc nucl i j partial_inst
+  = [ mk_var i (dgf_base wc_tfo (get_var j partial_inst) nucl) nucl ]
+
+let wc_dumas_tfo
+  = (
+      {    a= -0.9737; b= -0.1834; c=0.1352;
+           d= -0.1779; e=0.2417; f= -0.9539;
+           g=0.1422; h= -0.9529; i= -0.2679;
+           tx=0.4837; ty=6.2649; tz=8.0285 }
+    )
+
+let
+wc_dumas nucl i j partial_inst
+  = [ mk_var i (dgf_base wc_dumas_tfo (get_var j partial_inst) nucl) nucl ]
+
+let helix5'_tfo
+  = (
+      {    a=0.9886; b= -0.0961; c=0.1156;
+           d=0.1424; e=0.8452; f= -0.5152;
+           g= -0.0482; h=0.5258; i=0.8492;
+           tx= -3.8737; ty=0.5480; tz=3.8024 }
+    )
+
+let
+helix5' nucl i j partial_inst
+  = [ mk_var i (dgf_base helix5'_tfo (get_var j partial_inst) nucl) nucl ]
+
+let helix3'_tfo
+  = (
+      {    a=0.9886; b=0.1424; c= -0.0482;
+           d= -0.0961; e=0.8452; f=0.5258;
+           g=0.1156; h= -0.5152; i=0.8492;
+           tx=3.4426; ty=2.0474; tz= -3.7042 }
+    )
+
+let
+helix3' nucl i j partial_inst
+  = [ mk_var i (dgf_base helix3'_tfo (get_var j partial_inst) nucl) nucl ]
+
+let g37_a38_tfo
+  = (
+      {    a=0.9991; b=0.0164; c= -0.0387;
+           d= -0.0375; e=0.7616; f= -0.6470;
+           g=0.0189; h=0.6478; i=0.7615;
+           tx= -3.3018; ty=0.9975; tz=2.5585 }
+    )
+
+let
+g37_a38 nucl i j partial_inst
+  = mk_var i (dgf_base g37_a38_tfo (get_var j partial_inst) nucl) nucl
+
+let
+stacked5' nucl i j partial_inst
+  = (g37_a38 nucl i j partial_inst) :: (helix5' nucl i j partial_inst)
+
+let a38_g37_tfo
+  = (
+      {    a=0.9991; b= -0.0375; c=0.0189;
+           d=0.0164; e=0.7616; f=0.6478;
+           g= -0.0387; h= -0.6470; i=0.7615;
+           tx=3.3819; ty=0.7718; tz= -2.5321 }
+    )
+
+let
+a38_g37 nucl i j partial_inst
+  = mk_var i (dgf_base a38_g37_tfo (get_var j partial_inst) nucl) nucl
+
+let   
+stacked3' nucl i j partial_inst
+  = (a38_g37 nucl i j partial_inst) :: (helix3' nucl i j partial_inst)
+
+let
+p_o3' nucls i j partial_inst
+  = let refnuc = get_var j partial_inst in
+    let align = tfo_inv_ortho
+                    (tfo_align (atom_pos nuc_O3' refnuc)
+                               (atom_pos nuc_C3' refnuc)
+                               (atom_pos nuc_C4' refnuc)) in
+    let rec generate domains = function
+      [] -> domains
+    | n::ns ->
+         generate
+           ((mk_var i (tfo_combine (nuc_p_o3'_60_tfo n) align) n)::
+            (mk_var i (tfo_combine (nuc_p_o3'_180_tfo n) align) n)::
+            (mk_var i (tfo_combine (nuc_p_o3'_275_tfo n) align) n)::domains)
+           ns
+    in
+      generate [] nucls
+
+(* -- PROBLEM STATEMENT -----------------------------------------------------*)
+
+(* Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c *)
+
+let
+anticodon_domains
+  = [
+     reference rC  27;
+     helix5'   rC  28 27;
+     helix5'   rA  29 28;
+     helix5'   rG  30 29;
+     helix5'   rA  31 30;
+     wc        rU  39 31;
+     helix5'   rC  40 39;
+     helix5'   rU  41 40;
+     helix5'   rG  42 41;
+     helix5'   rG  43 42;
+     stacked3' rA  38 39;
+     stacked3' rG  37 38;
+     stacked3' rA  36 37;
+     stacked3' rA  35 36;
+     stacked3' rG  34 35; (* <-. Distance      *)
+     p_o3'     rCs 32 31; (*   | Constraint    *)
+     p_o3'     rUs 33 32  (* <-' 3.0 Angstroms *)
+    ]
+
+(* Anticodon constraint *)
+
+let
+anticodon_constraint v partial_inst =
+  let rec dist j = let p = atom_pos nuc_P (get_var j partial_inst) in
+                   let o3' = atom_pos nuc_O3' v in
+                     pt_dist p o3'
+  in
+      if v.id = 33 then
+        (dist 34) <= 3.0
+      else
+        true
+
+let
+anticodon () = search [] anticodon_domains anticodon_constraint
+
+(* Define pseudoknot problem -- Science 253:1255 Figure 4a and 4b *)
+
+let
+pseudoknot_domains
+  = [
+     reference rA  23;
+     wc_dumas  rU   8 23;
+     helix3'   rG  22 23;
+     wc_dumas  rC   9 22;
+     helix3'   rG  21 22;
+     wc_dumas  rC  10 21;
+     helix3'   rC  20 21;
+     wc_dumas  rG  11 20;
+     helix3'   rU' 19 20; (* <-.               *)
+     wc_dumas  rA  12 19; (*   | Distance      *)
+(*                             | Constraint    *)
+(*  Helix 1                    | 4.0 Angstroms *)
+     helix3'   rC   3 19; (*   |               *)
+     wc_dumas  rG  13  3; (*   |               *)
+     helix3'   rC   2  3; (*   |               *)
+     wc_dumas  rG  14  2; (*   |               *)
+     helix3'   rC   1  2; (*   |               *)
+     wc_dumas  rG' 15  1; (*   |               *)
+(*                             |               *)
+(*  L2 LOOP                    |               *)
+     p_o3'     rUs 16 15; (*   |               *)
+     p_o3'     rCs 17 16; (*   |               *)
+     p_o3'     rAs 18 17; (* <-'               *)
+(*                                             *)
+(*  L1 LOOP                                    *)
+     helix3'   rU   7  8; (* <-.               *)
+     p_o3'     rCs  4  3; (*   | Constraint    *)
+     stacked5' rU   5  4; (*   | 4.5 Angstroms *)
+     stacked5' rC   6  5  (* <-'               *)
+    ]
+  
+(* Pseudoknot constraint *)
+
+let
+pseudoknot_constraint v partial_inst =
+    let rec dist j =
+        let p = atom_pos nuc_P (get_var j partial_inst) in
+        let o3' = atom_pos nuc_O3' v in
+        pt_dist p o3'
+    in
+      if v.id = 18 then
+        (dist 19) <= 4.0
+      else if v.id = 6 then
+        (dist 7) <= 4.5
+      else
+        true
+
+let
+pseudoknot () = search [] pseudoknot_domains pseudoknot_constraint
+
+(* -- TESTING ---------------------------------------------------------------*)
+
+let list_of_atoms = function
+  (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,
+   A (n6,n7,n9,c8,h2,h61,h62,h8)))
+  -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3';
+     h3';o3';n1;n3;c2;c4;c5;c6;n6;n7;n9;c8;h2;h61;h62;h8|]
+
+| (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,
+   C (n4,o2,h41,h42,h5,h6)))
+  -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3';
+     h3';o3';n1;n3;c2;c4;c5;c6;n4;o2;h41;h42;h5;h6|]
+
+| (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,
+   G (n2,n7,n9,c8,o6,h1,h21,h22,h8)))
+  -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3';
+     h3';o3';n1;n3;c2;c4;c5;c6;n2;n7;n9;c8;o6;h1;h21;h22;h8|]
+
+| (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo,
+   p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2',
+   c3',h3',o3',n1,n3,c2,c4,c5,c6,
+   U (o2,o4,h3,h5,h6)))
+  -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3';
+     h3';o3';n1;n3;c2;c4;c5;c6;o2;o4;h3;h5;h6|]
+
+let maximum = function
+  | x::xs ->
+     let rec iter m = function
+       [] -> m
+     | (a::b) -> iter (if a > m then a else m) b
+     in
+       iter x xs
+  | _ -> assert false
+
+let
+var_most_distant_atom v =
+  let atoms = list_of_atoms v.n in
+  let max_dist = ref 0.0 in
+  for i = 0 to pred (Array.length atoms) do
+    let p = atoms.(i) in
+    let distance = 
+      let pos = absolute_pos v p
+      in sqrt ((pos.x * pos.x) + (pos.y * pos.y) + (pos.z * pos.z)) in
+    if distance > !max_dist then max_dist := distance
+  done;
+  !max_dist
+
+let
+sol_most_distant_atom s = maximum (List.map var_most_distant_atom s)
+
+let
+most_distant_atom sols = maximum (List.map sol_most_distant_atom sols)
+
+let
+check () = List.length (pseudoknot ())
+
+let
+run () = most_distant_atom (pseudoknot ())
+
+let main () = Printf.printf "%.4f" (run ()); print_newline()
+
+let _ = main ()
diff --git a/test/ocamldoc/Makefile b/test/ocamldoc/Makefile
new file mode 100644
index 00000000..0beaefc6
--- /dev/null
+++ b/test/ocamldoc/Makefile
@@ -0,0 +1,40 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#         Maxence Guesdon, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2004 Institut National de Recherche 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.1 2004/02/20 16:02:03 guesdon Exp $ 
+
+ROOT=../..
+include $(ROOT)/config/Makefile
+
+CAMLC=$(ROOT)/boot/ocamlrun $(ROOT)/ocamlc
+CAMLOPT=$(ROOT)/boot/ocamlrun $(ROOT)/ocamlopt
+COMPFLAGS=-nostdlib -I $(ROOT)/stdlib -I KB -I Lex
+OPTFLAGS=-S
+CAMLYACC=$(ROOT)/yacc/ocamlyacc
+YACCFLAGS=-v
+CAMLLEX=$(ROOT)/boot/ocamlrun $(ROOT)/lex/ocamllex
+CAMLDEP=$(ROOT)/boot/ocamlrun $(ROOT)/tools/ocamldep
+CAMLRUN=$(ROOT)/byterun/ocamlrun
+OCAMLDOC=$(ROOT)/boot/ocamlrun $(ROOT)/ocamldoc/ocamldoc
+OCAMLDOC_TEST=$(OCAMLDOC) -g $(ROOT)/ocamldoc/odoc_test.cmo -warn-error
+
+
+all:
+	for i in *.ml; do $(MAKE) TARGET=`basename $$i .ml` test_one; done
+
+test_one: results/$(TARGET).txt
+
+results/$(TARGET).txt : $(TARGET).ml
+	$(OCAMLDOC_TEST) -o $@ $< 2> results/$(TARGET).stderr
+
+clean:
+	rm -f results/*.txt results/*.stderr
\ No newline at end of file
diff --git a/test/ocamldoc/t1.ml b/test/ocamldoc/t1.ml
new file mode 100644
index 00000000..6caf3d7a
--- /dev/null
+++ b/test/ocamldoc/t1.ml
@@ -0,0 +1,19 @@
+(** Testing display of types.
+
+   @test_types_display
+ *)
+
+let x = 1
+
+
+module M = struct
+  let y = 2 
+
+end
+
+module type MT = sig
+  type t = string -> int -> string -> (string * string * string) ->
+    (string * string * string) ->
+      (string * string * string) -> unit
+  val y : int
+end
diff --git a/test/quicksort.ml b/test/quicksort.ml
new file mode 100644
index 00000000..ec28a6c3
--- /dev/null
+++ b/test/quicksort.ml
@@ -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: quicksort.ml,v 1.6 2000/12/28 13:06:37 weis Exp $ *)
+
+(* Good test for loops. Best compiled with -unsafe. *)
+
+let rec qsort lo hi (a : int array) =
+  if lo < hi then begin
+    let i = ref lo in
+    let j = ref hi in
+    let pivot = a.(hi) in
+    while !i < !j do
+      while !i < hi && a.(!i) <= pivot do incr i done;
+      while !j > lo && a.(!j) >= pivot do decr j done;
+      if !i < !j then begin
+        let temp = a.(!i) in a.(!i) <- a.(!j); a.(!j) <- temp
+      end
+    done;
+    let temp = a.(!i) in a.(!i) <- a.(hi); a.(hi) <- temp;
+    qsort lo (!i-1) a;
+    qsort (!i+1) hi a
+  end
+
+
+(* Same but abstract over the comparison to force spilling *)
+
+let cmp i j = i - j
+
+let rec qsort2 lo hi (a : int array) =
+  if lo < hi then begin
+    let i = ref lo in
+    let j = ref hi in
+    let pivot = a.(hi) in
+    while !i < !j do
+      while !i < hi && cmp a.(!i) pivot <= 0 do incr i done;
+      while !j > lo && cmp a.(!j) pivot >= 0 do decr j done;
+      if !i < !j then begin
+        let temp = a.(!i) in a.(!i) <- a.(!j); a.(!j) <- temp
+      end
+    done;
+    let temp = a.(!i) in a.(!i) <- a.(hi); a.(hi) <- temp;
+    qsort2 lo (!i-1) a;
+    qsort2 (!i+1) hi a
+  end
+
+
+(* Test *)
+
+let seed = ref 0
+
+let random() =
+  seed := !seed * 25173 + 17431; !seed land 0xFFF
+
+
+exception Failed
+
+let test_sort sort_fun size =
+  let a = Array.create size 0 in
+  let check = Array.create 4096 0 in
+  for i = 0 to size-1 do
+    let n = random() in a.(i) <- n; check.(n) <- check.(n)+1
+  done;
+  sort_fun 0 (size-1) a;
+  try
+    check.(a.(0)) <- check.(a.(0)) - 1;
+    for i = 1 to size-1 do
+      if a.(i-1) > a.(i) then raise Failed;
+      check.(a.(i)) <- check.(a.(i)) - 1
+    done;
+    for i = 0 to 4095 do
+      if check.(i) <> 0 then raise Failed
+    done;
+    print_string "OK";  print_newline()
+  with Failed ->
+    print_string "failed"; print_newline()
+
+
+let main () =
+  test_sort qsort 50000;
+  test_sort qsort2 50000
+
+let _ = main(); exit 0
diff --git a/test/sieve.ml b/test/sieve.ml
new file mode 100644
index 00000000..137af1cc
--- /dev/null
+++ b/test/sieve.ml
@@ -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: sieve.ml,v 1.4 1999/11/17 18:58:34 xleroy Exp $ *)
+
+(* Eratosthene's sieve *)
+
+(* interval min max = [min; min+1; ...; max-1; max] *)
+
+let rec interval min max =
+  if min > max then [] else min :: interval (min + 1) max
+
+
+(* filter p L returns the list of the elements in list L
+   that satisfy predicate p *)
+
+let rec filter p = function
+     []  -> []
+  | a::r -> if p a then a :: filter p r else filter p r
+
+
+(* Application: removing all numbers multiple of n from a list of integers *)
+
+let remove_multiples_of n =
+  filter (fun m -> m mod n <> 0)
+
+
+(* The sieve itself *)
+
+let sieve max =
+  let rec filter_again = function
+     [] -> []
+  | n::r as l ->
+      if n*n > max then l else n :: filter_again (remove_multiples_of n r)
+  in
+    filter_again (interval 2 max)
+
+
+let rec do_list f = function
+    [] -> ()
+  | a::l -> f a; do_list f l
+
+
+let _ =
+  do_list (fun n -> print_int n; print_string " ") (sieve 40000);
+  print_newline();
+  exit 0
diff --git a/test/soli.ml b/test/soli.ml
new file mode 100644
index 00000000..684d646f
--- /dev/null
+++ b/test/soli.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: soli.ml,v 1.4 1999/11/17 18:58:34 xleroy Exp $ *)
+
+
+type peg = Out | Empty | Peg
+
+let board = [|
+ [| Out; Out; Out; Out; Out; Out; Out; Out; Out|];
+ [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|];
+ [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|];
+ [| Out; Peg; Peg; Peg; Peg; Peg; Peg; Peg; Out|];
+ [| Out; Peg; Peg; Peg; Empty; Peg; Peg; Peg; Out|];
+ [| Out; Peg; Peg; Peg; Peg; Peg; Peg; Peg; Out|];
+ [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|];
+ [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|];
+ [| Out; Out; Out; Out; Out; Out; Out; Out; Out|]
+|]
+
+
+let print_peg = function
+    Out -> print_string "."
+  | Empty -> print_string " "
+  | Peg -> print_string "$"
+
+
+let print_board board =
+ for i=0 to 8 do
+   for j=0 to 8 do
+    print_peg board.(i).(j)
+   done;
+   print_newline()
+ done
+
+
+type direction = { dx: int; dy: int }
+
+let dir = [| {dx = 0; dy = 1}; {dx = 1; dy = 0};
+             {dx = 0; dy = -1}; {dx = -1; dy = 0} |]
+
+type move = { x1: int; y1: int; x2: int; y2: int }
+
+let moves = Array.create 31 {x1=0;y1=0;x2=0;y2=0}
+
+let counter = ref 0
+
+exception Found
+
+let rec solve m =
+  counter := !counter + 1;
+  if m = 31 then
+    begin match board.(4).(4) with Peg -> true | _ -> false end
+  else
+    try
+      if !counter mod 500 = 0 then begin
+        print_int !counter; print_newline()
+      end;
+      for i=1 to 7 do
+      for j=1 to 7 do
+        match board.(i).(j) with
+          Peg ->
+            for k=0 to 3 do
+              let d1 = dir.(k).dx in
+              let d2 = dir.(k).dy in
+              let i1 = i+d1 in
+              let i2 = i1+d1 in
+              let j1 = j+d2 in
+              let j2 = j1+d2 in
+              match board.(i1).(j1) with
+                Peg ->
+                  begin match board.(i2).(j2) with
+                    Empty ->
+(*
+                      print_int i; print_string ", ";
+                      print_int j; print_string ") dir ";
+                      print_int k; print_string "\n";
+*)
+                      board.(i).(j) <- Empty;
+                      board.(i1).(j1) <- Empty;
+                      board.(i2).(j2) <- Peg;
+                      if solve(m+1) then begin
+                        moves.(m) <- { x1=i; y1=j; x2=i2; y2=j2 };
+                        raise Found
+                      end;
+                      board.(i).(j) <- Peg;
+                      board.(i1).(j1) <- Peg;
+                      board.(i2).(j2) <- Empty
+                    | _ -> ()
+                  end
+              | _ -> ()
+            done
+        | _ ->
+            ()
+      done
+      done;
+      false
+    with Found ->
+      true
+
+
+let _ = if solve 0 then (print_string "\n"; print_board board)
diff --git a/test/sorts.ml b/test/sorts.ml
new file mode 100644
index 00000000..859ff0e3
--- /dev/null
+++ b/test/sorts.ml
@@ -0,0 +1,4477 @@
+(* Test bench for sorting algorithms. *)
+
+
+(*
+  ocamlopt -noassert sorts.ml -cclib -lunix
+*)
+
+open Printf;;
+
+(*
+  Criteres:
+  0. overhead en pile: doit etre logn au maximum.
+  1. stable ou non.
+  2. overhead en espace.
+  3. vitesse.
+*)
+
+(************************************************************************)
+(* auxiliary functions *)
+
+let rec exp2 n = if n <= 0 then 1 else 2 * exp2 (n-1);;
+let id x = x;;
+let postl x y = Array.of_list y;;
+let posta x y = x;;
+
+let mkconst n = Array.make n 0;;
+let chkconst _ n a = (a = mkconst n);;
+
+let mksorted n =
+  let a = Array.make n 0 in
+  for i = 0 to n - 1 do
+    a.(i) <- i;
+  done;
+  a
+;;
+let chksorted _ n a = (a = mksorted n);;
+
+let mkrev n =
+  let a = Array.make n 0 in
+  for i = 0 to n - 1 do
+    a.(i) <- n - 1 - i;
+  done;
+  a
+;;
+let chkrev _ n a = (a = mksorted n);;
+
+let seed = ref 0;;
+let random_reinit () = Random.init !seed;;
+
+let random_get_state () =
+  let a = Array.make 55 0 in
+  for i = 0 to 54 do a.(i) <- Random.bits (); done;
+  Random.full_init a;
+  a
+;;
+let random_set_state a = Random.full_init a;;
+
+let chkgen mke cmp rstate n a =
+  let marks = Array.make n (-1) in
+  let skipmarks l =
+    if marks.(l) = -1 then l else begin
+      let m = ref marks.(l) in
+      while marks.(!m) <> -1 do incr m; done;
+      marks.(l) <- !m;
+      !m
+    end
+  in
+  let linear e l =
+    let l = skipmarks l in
+    let rec loop l =
+      if cmp a.(l) e > 0 then raise Exit
+      else if e = a.(l) then marks.(l) <- l+1
+      else loop (l+1)
+    in loop l
+  in
+  let rec dicho e l r =
+    if l = r then linear e l
+    else begin
+      assert (l < r);
+      let m = (l + r) / 2 in
+      if cmp a.(m) e >= 0 then dicho e l m else dicho e (m + 1) r
+    end
+  in
+  try
+    for i = 0 to n-2 do if cmp a.(i) a.(i+1) > 0 then raise Exit; done;
+    random_set_state rstate;
+    for i = 0 to n-1 do dicho (mke i) 0 (Array.length a - 1); done;
+    true
+  with Exit | Invalid_argument _ -> false;
+;;
+
+let mkrand_dup n =
+  let a = Array.make n 0 in
+  for i = 0 to (n-1) do a.(i) <- Random.int n; done;
+  a
+;;
+
+let chkrand_dup rstate n a =
+  chkgen (fun i -> Random.int n) compare rstate n a
+;;
+
+let mkrand_nodup n =
+  let a = Array.make n 0 in
+  for i = 0 to (n-1) do a.(i) <- Random.bits (); done;
+  a
+;;
+
+let chkrand_nodup rstate n a =
+  chkgen (fun i -> Random.bits ()) compare rstate n a
+;;
+
+let mkfloats n =
+  let a = Array.make n 0.0 in
+  for i = 0 to (n-1) do a.(i) <- Random.float 1.0; done;
+  a
+;;
+
+let chkfloats rstate n a =
+  chkgen (fun i -> Random.float 1.0) compare rstate n a
+;;
+
+type record = {
+  s1 : string;
+  s2 : string;
+  i1 : int;
+  i2 : int;
+};;
+
+let rand_string () =
+  let len = Random.int 10 in
+  let s = String.create len in
+  for i = 0 to len-1 do
+    s.[i] <- Char.chr (Random.int 256);
+  done;
+  s
+;;
+
+let mkrec1 b i = {
+  s1 = rand_string ();
+  s2 = rand_string ();
+  i1 = Random.int b;
+  i2 = i;
+};;
+
+let mkrecs b n = Array.init n (mkrec1 b);;
+
+let mkrec1_rev b i = {
+  s1 = rand_string ();
+  s2 = rand_string ();
+  i1 = - i;
+  i2 = i;
+};;
+
+let mkrecs_rev n = Array.init n (mkrec1_rev 0);;
+
+let cmpstr r1 r2 =
+  let c1 = compare r1.s1 r2.s1 in
+  if c1 = 0 then compare r1.s2 r2.s2 else c1
+;;
+let lestr r1 r2 =
+  let c1 = compare r1.s1 r2.s1 in
+  if c1 = 0 then r1.s2 <= r2.s2 else (c1 < 0)
+;;
+let chkstr b rstate n a = chkgen (mkrec1 b) cmpstr rstate n a;;
+
+let cmpint r1 r2 = compare r1.i1 r2.i1;;
+let leint r1 r2 = r1.i1 <= r2.i1;;
+let chkint b rstate n a = chkgen (mkrec1 b) cmpint rstate n a;;
+
+let cmplex r1 r2 =
+  let c1 = compare r1.i1 r2.i1 in
+  if c1 = 0 then compare r1.i2 r2.i2 else c1
+;;
+let lelex r1 r2 =
+  let c1 = compare r1.i1 r2.i1 in
+  if c1 = 0 then r1.i2 <= r2.i2 else (c1 < 0)
+;;
+let chklex b rstate n a = chkgen (mkrec1 b) cmplex rstate n a;;
+
+(************************************************************************)
+
+let lens = [
+  0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 28;
+  100; 127; 128; 129; 191; 192; 193; 506;
+  1000; 1023; 1024; 1025; 1535; 1536; 1537; 2323;
+  4000; 4094; 4096; 4098; 5123;
+];;
+
+type ('a, 'b, 'c, 'd) aux = {
+  prepf : ('a -> 'a -> int) -> ('a -> 'a -> bool) -> 'b;
+  prepd : 'a array -> 'c;
+  postd : 'a array -> 'd -> 'a array;
+};;
+
+let ll = { prepf = (fun x y -> y); prepd = Array.to_list; postd = postl };;
+let lc = { prepf = (fun x y -> x); prepd = Array.to_list; postd = postl };;
+let al = { prepf = (fun x y -> y); prepd = id; postd = posta };;
+let ac = { prepf = (fun x y -> x); prepd = id; postd = posta };;
+
+type 'a outcome = Value of 'a | Exception of exn;;
+
+let numfailed = ref 0;;
+
+let test1 name f prepdata postdata cmp desc mk chk =
+  random_reinit ();
+  printf "  %s with %s" name desc;
+  let i = ref 0 in
+  List.iter (fun n ->
+      if !i = 0 then printf "\n    "; incr i; if !i > 11 then i := 0;
+      printf "%5d" n; flush stdout;
+      let rstate = random_get_state () in
+      let a = mk n in
+      let input = prepdata a in
+      let output = try Value (f cmp input) with e -> Exception e in
+      printf "."; flush stdout;
+      begin match output with
+      | Value v ->
+         if not (chk rstate n (postdata a v))
+         then (incr numfailed; printf "\n*** FAIL\n")
+      | Exception e ->
+         incr numfailed; printf "\n*** %s\n" (Printexc.to_string e)
+      end;
+      flush stdout;
+    ) lens;
+  printf "\n";
+;;
+
+let test name stable f1 f2 aux1 aux2 =
+  printf "Testing %s...\n" name;
+  let t a b c d = test1 name f1 aux1.prepd aux1.postd a b c d in
+  let cmp = aux1.prepf compare (<=) in
+  t cmp "constant ints" mkconst chkconst;
+  t cmp "sorted ints" mksorted chksorted;
+  t cmp "reverse-sorted ints" mkrev chkrev;
+  t cmp "random ints (many dups)" mkrand_dup chkrand_dup;
+  t cmp "random ints (few dups)" mkrand_nodup chkrand_nodup;
+(*
+  let t a b c d = test1 name f3 aux3.prepd aux3.postd a b c d in
+  t cmp "random floats" mkfloats chkfloats;
+*)
+  let t a b c d = test1 name f2 aux2.prepd aux2.postd a b c d in
+  let cmp = aux2.prepf cmpstr lestr in
+  t cmp "records (str)" (mkrecs 1) (chkstr 1);
+  let cmp = aux2.prepf cmpint leint in
+  List.iter (fun m -> t cmp (sprintf "records (int[%d])" m) (mkrecs m)
+                        (chkint m)
+            ) [1; 10; 100; 1000];
+  if stable then
+    List.iter (fun m -> t cmp (sprintf "records (int[%d]) [stable]" m)
+                          (mkrecs m) (chklex m)
+              ) [1; 10; 100; 1000];
+;;
+
+(************************************************************************)
+
+(* Warning: rpt_timer cannot be used for the array sorts because
+   the sorting functions have effects.
+*)
+
+let rpt_timer1 repeat f x =
+  Gc.compact ();
+  ignore (f x);
+  let st = Sys.time () in
+  for i = 1 to repeat do ignore (f x); done;
+  let en = Sys.time () in
+  en -. st
+;;
+
+let rpt_timer f x =
+  let repeat = ref 1 in
+  let t = ref (rpt_timer1 !repeat f x) in
+  while !t < 0.2 do
+    repeat := 10 * !repeat;
+    t := rpt_timer1 !repeat f x;
+  done;
+  if !t < 2.0 then begin
+    repeat := (int_of_float (10. *. (float !repeat) /. !t) + 1);
+    t := rpt_timer1 !repeat f x;
+  end;
+  !t /. (float !repeat)
+;;
+
+let timer f x =
+  let st = Sys.time () in
+  ignore (f x);
+  let en = Sys.time () in
+  (en -. st)
+;;
+
+let table1 limit f mkarg =
+  printf "  %10s  %9s  %9s  %9s  %9s  %9s\n" "n" "t1" "t2" "t3" "t4" "t5";
+  let sz = ref 49151 in
+  while !sz < int_of_float (2. ** float limit) do
+    begin try
+      printf "  %10d  " !sz; flush stdout;
+      for i = 0 to 4 do
+        let arg = mkarg !sz in
+        let t = timer f arg in
+        printf " %.2e   " t; flush stdout;
+      done;
+      printf "\n";
+    with e -> printf "*** %s\n" (Printexc.to_string e);
+    end;
+    flush stdout;
+    sz := 2 * !sz + 1;
+  done;
+;;
+
+let table2 limit f mkarg =
+  printf "  %10s  %9s  %9s  %9s  %9s  %9s\n"
+         " n" "t" "t/n" "t/nlogn" "t/nlog^2n" "t/n^2";
+  let sz = ref 49151 in
+  while float !sz < 2. ** float limit do
+    begin try
+      printf "  %10d   " !sz; flush stdout;
+      Gc.compact ();
+      let arg = mkarg !sz in
+      let t = timer f arg in
+      let n = float !sz in
+      let logn = log (float !sz) /. log 2. in
+      printf "%.2e   %.2e   %.2e   %.2e   %.2e\n"
+             t (t/.n) (t/.n/.logn) (t/.n/.logn/.logn) (t/.n/.n);
+    with e -> printf "*** %s\n" (Printexc.to_string e);
+    end;
+    flush stdout;
+    sz := 2 * !sz + 1;
+  done;
+;;
+
+let table3 limit f mkarg =
+  printf "  %10s  %9s  %9s  %9s  %9s  %9s\n" "n" "t1" "t2" "t3" "t4" "t5";
+  let sz = ref 2 in
+  while float !sz < 2. ** float limit do
+    begin try
+      printf "  %10d  " !sz; flush stdout;
+      for i = 0 to 4 do
+        let arg = mkarg !sz in
+        let t = rpt_timer f arg in
+        printf " %.2e   " t; flush stdout;
+      done;
+      printf "\n";
+    with e -> printf "*** %s\n" (Printexc.to_string e);
+    end;
+    flush stdout;
+    sz := 2 * !sz + 1;
+  done;
+;;
+
+(************************************************************************)
+
+(* benchmarks:
+   1a. random records, sorted with two keys
+   1b. random integers
+   1c. random floats
+
+   2a. integers, constant
+   2b. integers, already sorted
+   2c. integers, reverse sorted
+
+   only for short lists:
+   3a. random records, sorted with two keys
+   3b. random integers
+   3c. random floats
+*)
+let bench1a limit name f aux =
+
+  (* Don't do benchmarks with assertions enabled. *)
+  assert (not true);
+
+  random_reinit ();
+
+  printf "\n%s with random records [10]:\n" name;
+  let cmp = aux.prepf cmplex lelex in
+  table1 limit (f cmp) (fun n -> aux.prepd (mkrecs 10 n));
+;;
+
+let bench1b limit name f aux =
+
+  (* Don't do benchmarks with assertions enabled. *)
+  assert (not true);
+
+  random_reinit ();
+
+  printf "\n%s with random integers:\n" name;
+  let cmp = aux.prepf (-) (<=) in
+  table1 limit (f cmp) (fun n -> aux.prepd (mkrand_nodup n));
+;;
+
+let bench1c limit name f aux =
+
+  (* Don't do benchmarks with assertions enabled. *)
+  assert (not true);
+
+  random_reinit ();
+
+  printf "\n%s with random floats:\n" name;
+  let cmp = aux.prepf compare (<=) in
+  table1 limit (f cmp) (fun n -> aux.prepd (mkfloats n));
+;;
+
+let bench2 limit name f aux =
+
+  (* Don't do benchmarks with assertions enabled. *)
+  assert (not true);
+
+  printf "\n%s with constant integers:\n" name;
+  let cmp = aux.prepf compare (<=) in
+  table2 limit (f cmp) (fun n -> aux.prepd (mkconst n));
+
+  printf "\n%s with sorted integers:\n" name;
+  let cmp = aux.prepf compare (<=) in
+  table2 limit (f cmp) (fun n -> aux.prepd (mksorted n));
+
+  printf "\n%s with reverse-sorted integers:\n" name;
+  let cmp = aux.prepf compare (<=) in
+  table2 limit (f cmp) (fun n -> aux.prepd (mkrev n));
+;;
+
+let bench3a limit name f aux =
+
+  (* Don't do benchmarks with assertions enabled. *)
+  assert (not true);
+
+  random_reinit ();
+
+  printf "\n%s with random records [10]:\n" name;
+  let cmp = aux.prepf cmplex lelex in
+  table3 limit (f cmp) (fun n -> aux.prepd (mkrecs 10 n));
+;;
+
+let bench3b limit name f aux =
+
+  (* Don't do benchmarks with assertions enabled. *)
+  assert (not true);
+
+  random_reinit ();
+
+  printf "\n%s with random integers:\n" name;
+  let cmp = aux.prepf (-) (<=) in
+  table3 limit (f cmp) (fun n -> aux.prepd (mkrand_nodup n));
+;;
+
+let bench3c limit name f aux =
+
+  (* Don't do benchmarks with assertions enabled. *)
+  assert (not true);
+
+  random_reinit ();
+
+  printf "\n%s with random floats:\n" name;
+  let cmp = aux.prepf compare (<=) in
+  table3 limit (f cmp) (fun n -> aux.prepd (mkfloats n));
+;;
+
+(************************************************************************)
+(* merge sort on lists *)
+
+(* FIXME to do: cutoff
+         to do: cascader les pattern-matchings (enlever les paires)
+         to do: fermeture intermediaire pour merge
+*)
+let (@@) = List.rev_append;;
+
+let lmerge_1a cmp l =
+  let rec init accu = function
+    | [] -> accu
+    | e::rest -> init ([e] :: accu) rest
+  in
+  let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
+                                           accu,accu2 are rev *)
+    match l1, l2 with
+    | []    , _      -> mergepairs ((l2 @@ accu)::accu2) rest
+    | _     , []     -> mergepairs ((l1 @@ accu)::accu2) rest
+    | h1::t1, h2::t2 -> if cmp h1 h2 <= 0
+                        then merge rest accu2 (h1::accu) t1 l2
+                        else merge rest accu2 (h2::accu) l1 t2
+  and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
+                                           l1,l2,rest are rev *)
+    match l1, l2 with
+    | []    , _      -> mergepairs_rev ((l2 @@ accu)::accu2) rest
+    | _     , []     -> mergepairs_rev ((l1 @@ accu)::accu2) rest
+    | h1::t1, h2::t2 -> if cmp h2 h1 <= 0
+                        then merge_rev rest accu2 (h1::accu) t1 l2
+                        else merge_rev rest accu2 (h2::accu) l1 t2
+  and mergepairs accu = function       (* accu is rev, arg is forward *)
+    | [] -> mergeall_rev accu
+    | [l] -> mergeall_rev ((List.rev l)::accu)
+    | l1::l2::rest -> merge rest accu [] l1 l2
+  and mergepairs_rev accu = function   (* accu is forward, arg is rev *)
+    | [] -> mergeall accu
+    | [l] -> mergeall ((List.rev l)::accu)
+    | l1::l2::rest -> merge_rev rest accu [] l1 l2
+  and mergeall = function              (* arg is forward *)
+    | [] -> []
+    | [l] -> l
+    | llist -> mergepairs [] llist
+  and mergeall_rev = function          (* arg is rev *)
+    | [] -> []
+    | [l] -> List.rev l
+    | llist -> mergepairs_rev [] llist
+  in
+  mergeall_rev (init [] l)
+;;
+
+let lmerge_1b cmp l =
+  let rec init accu = function
+    | [] -> accu
+    | [e] -> [e] :: accu
+    | e1::e2::rest ->
+        init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest
+  in
+  let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
+                                           accu,accu2 are rev *)
+    match l1, l2 with
+    | []    , _      -> mergepairs ((l2 @@ accu)::accu2) rest
+    | _     , []     -> mergepairs ((l1 @@ accu)::accu2) rest
+    | h1::t1, h2::t2 -> if cmp h1 h2 <= 0
+                        then merge rest accu2 (h1::accu) t1 l2
+                        else merge rest accu2 (h2::accu) l1 t2
+  and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
+                                           l1,l2,rest are rev *)
+    match l1, l2 with
+    | []    , _      -> mergepairs_rev ((l2 @@ accu)::accu2) rest
+    | _     , []     -> mergepairs_rev ((l1 @@ accu)::accu2) rest
+    | h1::t1, h2::t2 -> if cmp h2 h1 <= 0
+                        then merge_rev rest accu2 (h1::accu) t1 l2
+                        else merge_rev rest accu2 (h2::accu) l1 t2
+  and mergepairs accu = function       (* accu is rev, arg is forward *)
+    | [] -> mergeall_rev accu
+    | [l] -> mergeall_rev ((List.rev l)::accu)
+    | l1::l2::rest -> merge rest accu [] l1 l2
+  and mergepairs_rev accu = function   (* accu is forward, arg is rev *)
+    | [] -> mergeall accu
+    | [l] -> mergeall ((List.rev l)::accu)
+    | l1::l2::rest -> merge_rev rest accu [] l1 l2
+  and mergeall = function              (* arg is forward *)
+    | [] -> []
+    | [l] -> l
+    | llist -> mergepairs [] llist
+  and mergeall_rev = function          (* arg is rev *)
+    | [] -> []
+    | [l] -> List.rev l
+    | llist -> mergepairs_rev [] llist
+  in
+  mergeall_rev (init [] l)
+;;
+
+let lmerge_1c cmp l =
+  let rec init accu = function
+    | [] -> accu
+    | [e] -> [e] :: accu
+    | e1::e2::rest ->
+        init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest
+  in
+  let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
+                                           accu,accu2 are rev *)
+    match l1 with
+    | [] -> mergepairs ((l2 @@ accu)::accu2) rest
+    | h1::t1 ->
+       match l2 with
+       | []     -> mergepairs ((l1 @@ accu)::accu2) rest
+       | h2::t2 -> if cmp h1 h2 <= 0
+                   then merge rest accu2 (h1::accu) t1 l2
+                   else merge rest accu2 (h2::accu) l1 t2
+  and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
+                                           l1,l2,rest are rev *)
+    match l1 with
+    | [] -> mergepairs_rev ((l2 @@ accu)::accu2) rest
+    | h1::t1 ->
+       match l2 with
+       | []     -> mergepairs_rev ((l1 @@ accu)::accu2) rest
+       | h2::t2 -> if cmp h2 h1 <= 0
+                   then merge_rev rest accu2 (h1::accu) t1 l2
+                   else merge_rev rest accu2 (h2::accu) l1 t2
+  and mergepairs accu = function       (* accu is rev, arg is forward *)
+    | [] -> mergeall_rev accu
+    | [l] -> mergeall_rev ((List.rev l)::accu)
+    | l1::l2::rest -> merge rest accu [] l1 l2
+  and mergepairs_rev accu = function   (* accu is forward, arg is rev *)
+    | [] -> mergeall accu
+    | [l] -> mergeall ((List.rev l)::accu)
+    | l1::l2::rest -> merge_rev rest accu [] l1 l2
+  and mergeall = function              (* arg is forward *)
+    | [] -> []
+    | [l] -> l
+    | llist -> mergepairs [] llist
+  and mergeall_rev = function          (* arg is rev *)
+    | [] -> []
+    | [l] -> List.rev l
+    | llist -> mergepairs_rev [] llist
+  in
+  mergeall_rev (init [] l)
+;;
+
+let lmerge_1d cmp l =
+  let rec init accu = function
+    | [] -> accu
+    | [e] -> [e] :: accu
+    | e1::e2::rest ->
+        init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest
+  in
+  let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward;
+                                           accu,accu2 are rev *)
+    let merge_rest_accu2 accu l1 l2 =
+      match l1 with
+      | [] -> mergepairs ((l2 @@ accu)::accu2) rest
+      | h1::t1 ->
+         match l2 with
+         | []     -> mergepairs ((l1 @@ accu)::accu2) rest
+         | h2::t2 -> if cmp h1 h2 <= 0
+                     then merge rest accu2 (h1::accu) t1 l2
+                     else merge rest accu2 (h2::accu) l1 t2
+    in merge_rest_accu2 accu l1 l2
+  and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward;
+                                           l1,l2,rest are rev *)
+    let merge_rev_rest_accu2 accu l1 l2 =
+      match l1 with
+      | [] -> mergepairs_rev ((l2 @@ accu)::accu2) rest
+      | h1::t1 ->
+         match l2 with
+         | []     -> mergepairs_rev ((l1 @@ accu)::accu2) rest
+         | h2::t2 -> if cmp h2 h1 <= 0
+                     then merge_rev rest accu2 (h1::accu) t1 l2
+                     else merge_rev rest accu2 (h2::accu) l1 t2
+    in merge_rev_rest_accu2 accu l1 l2
+  and mergepairs accu = function       (* accu is rev, arg is forward *)
+    | [] -> mergeall_rev accu
+    | [l] -> mergeall_rev ((List.rev l)::accu)
+    | l1::l2::rest -> merge rest accu [] l1 l2
+  and mergepairs_rev accu = function   (* accu is forward, arg is rev *)
+    | [] -> mergeall accu
+    | [l] -> mergeall ((List.rev l)::accu)
+    | l1::l2::rest -> merge_rev rest accu [] l1 l2
+  and mergeall = function              (* arg is forward *)
+    | [] -> []
+    | [l] -> l
+    | llist -> mergepairs [] llist
+  and mergeall_rev = function          (* arg is rev *)
+    | [] -> []
+    | [l] -> List.rev l
+    | llist -> mergepairs_rev [] llist
+  in
+  mergeall_rev (init [] l)
+;;
+
+(************************************************************************)
+(* merge sort on lists, user-contributed (NOT STABLE) *)
+
+(* BEGIN code contributed by Yann Coscoy *)
+
+  let rec rev_merge_append order l1 l2 acc =
+    match l1 with
+      [] ->  List.rev_append l2 acc
+    | h1 :: t1 ->
+        match l2 with
+          [] -> List.rev_append l1 acc
+        | h2 :: t2 ->
+            if order h1 h2
+            then  rev_merge_append order t1 l2 (h1::acc)
+            else  rev_merge_append order l1 t2 (h2::acc)
+
+  let rev_merge order l1 l2 = rev_merge_append order l1 l2 []
+
+  let rec rev_merge_append' order l1 l2 acc =
+    match l1 with
+    | [] ->  List.rev_append l2 acc
+    | h1 :: t1 ->
+        match l2 with
+          | [] -> List.rev_append l1 acc
+          | h2 :: t2 ->
+              if order h2 h1
+              then  rev_merge_append' order t1 l2 (h1::acc)
+              else  rev_merge_append' order l1 t2 (h2::acc)
+
+  let rev_merge' order l1 l2 = rev_merge_append' order l1 l2 []
+
+  let lmerge_3 order l =
+    let rec initlist l acc = match l with
+      | e1::e2::rest ->
+          initlist rest
+           ((if order e1 e2 then [e1;e2] else [e2;e1])::acc)
+      | [e] -> [e]::acc
+      | [] -> acc
+    in
+    let rec merge2 ll acc  = match ll with
+      | [] -> acc
+      | [l] -> [List.rev l]@acc
+      | l1::l2::rest ->
+          merge2 rest (rev_merge order l1 l2::acc)
+    in
+    let rec merge2' ll acc  = match ll with
+      | [] -> acc
+      | [l] -> [List.rev l]@acc
+      | l1::l2::rest ->
+          merge2' rest (rev_merge' order l1 l2::acc)
+    in
+    let rec mergeall rev = function
+      | [] -> []
+      | [l] -> if rev then List.rev l else l
+      | llist ->
+          mergeall
+          (not rev) ((if rev then merge2' else merge2) llist [])
+    in
+    mergeall false (initlist l [])
+
+(* END code contributed by Yann Coscoy *)
+
+(************************************************************************)
+(* merge sort on short lists, Francois Pottier *)
+
+(* BEGIN code contributed by Francois Pottier *)
+
+  (* [chop k l] returns the list [l] deprived of its [k] first
+     elements. The length of the list [l] must be [k] at least. *)
+
+  let rec chop k l =
+    match k, l with
+    | 0, _ -> l
+    | _, x :: l -> chop (k-1) l
+    | _, _ -> assert false
+  ;;
+
+  let rec merge order l1 l2 =
+    match l1 with
+      [] -> l2
+    | h1 :: t1 ->
+        match l2 with
+          [] -> l1
+        | h2 :: t2 ->
+            if order h1 h2
+            then h1 :: merge order t1 l2
+            else h2 :: merge order l1 t2
+  ;;
+
+  let rec lmerge_4a order l =
+    match l with
+    | []
+    | [ _ ] -> l
+    | _ ->
+        let rec sort k l = (* k > 1 *)
+          match k, l with
+          | 2, x1 :: x2 :: _ ->
+              if order x1 x2 then [ x1; x2 ] else [ x2; x1 ]
+          | 3, x1 :: x2 :: x3 :: _ ->
+              if order x1 x2 then
+                if order x2 x3 then
+                  [ x1 ; x2 ; x3 ]
+                else
+                  if order x1 x3 then [ x1 ; x3 ; x2 ] else [ x3; x1; x2 ]
+              else
+                if order x1 x3 then
+                  [ x2; x1; x3 ]
+                else
+                  if order x2 x3 then [ x2; x3; x1 ] else [ x3; x2; x1 ]
+          | _, _ ->
+              let k1 = k / 2 in
+              let k2 = k - k1 in
+              merge order (sort k1 l) (sort k2 (chop k1 l))
+        in
+        sort (List.length l) l
+  ;;
+(* END code contributed by Francois Pottier *)
+
+(************************************************************************)
+(* merge sort on short lists, Francois Pottier,
+   adapted to new-style interface *)
+
+(* BEGIN code contributed by Francois Pottier *)
+
+  (* [chop k l] returns the list [l] deprived of its [k] first
+     elements. The length of the list [l] must be [k] at least. *)
+
+  let rec chop k l =
+    match k, l with
+    | 0, _ -> l
+    | _, x :: l -> chop (k-1) l
+    | _, _ -> assert false
+  ;;
+
+  let rec merge order l1 l2 =
+    match l1 with
+      [] -> l2
+    | h1 :: t1 ->
+        match l2 with
+          [] -> l1
+        | h2 :: t2 ->
+            if order h1 h2 <= 0
+            then h1 :: merge order t1 l2
+            else h2 :: merge order l1 t2
+  ;;
+
+  let rec lmerge_4b order l =
+    match l with
+    | []
+    | [ _ ] -> l
+    | _ ->
+        let rec sort k l = (* k > 1 *)
+          match k, l with
+          | 2, x1 :: x2 :: _ ->
+              if order x1 x2 <= 0 then [ x1; x2 ] else [ x2; x1 ]
+          | 3, x1 :: x2 :: x3 :: _ ->
+              if order x1 x2 <= 0 then
+                if order x2 x3 <= 0 then
+                  [ x1 ; x2 ; x3 ]
+                else
+                  if order x1 x3 <= 0 then [ x1 ; x3 ; x2 ] else [ x3; x1; x2 ]
+              else
+                if order x1 x3 <= 0 then
+                  [ x2; x1; x3 ]
+                else
+                  if order x2 x3 <= 0 then [ x2; x3; x1 ] else [ x3; x2; x1 ]
+          | _, _ ->
+              let k1 = k / 2 in
+              let k2 = k - k1 in
+              merge order (sort k1 l) (sort k2 (chop k1 l))
+        in
+        sort (List.length l) l
+  ;;
+(* END code contributed by Francois Pottier *)
+
+(************************************************************************)
+(* merge sort on short lists a la Pottier, modified merge *)
+
+let rec chop k l =
+  if k = 0 then l else begin
+    match l with
+    | x::t -> chop (k-1) t
+    | _ -> assert false
+  end
+;;
+
+let lmerge_4c cmp l =
+  let rec merge1 h1 t1 l2 =
+    match l2 with
+    | [] -> h1 :: t1
+    | h2 :: t2 ->
+        if cmp h1 h2 <= 0
+        then h1 :: (merge2 t1 h2 t2)
+        else h2 :: (merge1 h1 t1 t2)
+  and merge2 l1 h2 t2 =
+    match l1 with
+    | [] -> h2 :: t2
+    | h1 :: t1 ->
+        if cmp h1 h2 <= 0
+        then h1 :: (merge2 t1 h2 t2)
+        else h2 :: (merge1 h1 t1 t2)
+  in
+  let merge l1 = function
+    | [] -> l1
+    | h2 :: t2 -> merge2 l1 h2 t2
+  in
+  let rec sort n l =
+    match n, l with
+    | 2, x1 :: x2 :: _ ->
+       if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1]
+    | 3, x1 :: x2 :: x3 :: _ ->
+       if cmp x1 x2 <= 0 then begin
+         if cmp x2 x3 <= 0 then [x1; x2; x3]
+         else if cmp x1 x3 <= 0 then [x1; x3; x2]
+         else [x3; x1; x2]
+       end else begin
+         if cmp x1 x3 <= 0 then [x2; x1; x3]
+         else if cmp x2 x3 <= 0 then [x2; x3; x1]
+         else [x3; x2; x1]
+       end
+    | n, l ->
+       let n1 = n asr 1 in
+       let n2 = n - n1 in
+       merge (sort n1 l) (sort n2 (chop n1 l))
+  in
+  let len = List.length l in
+  if len < 2 then l else sort len l
+;;
+
+(************************************************************************)
+(* merge sort on short lists a la Pottier, logarithmic stack space *)
+
+let rec chop k l =
+  if k = 0 then l else begin
+    match l with
+    | x::t -> chop (k-1) t
+    | _ -> assert false
+  end
+;;
+
+let lmerge_4d cmp l =
+  let rec rev_merge l1 l2 accu =
+    match l1, l2 with
+    | [], l2 -> l2 @@ accu
+    | l1, [] -> l1 @@ accu
+    | h1::t1, h2::t2 ->
+        if cmp h1 h2 <= 0
+        then rev_merge t1 l2 (h1::accu)
+        else rev_merge l1 t2 (h2::accu)
+  in
+  let rec rev_merge_rev l1 l2 accu =
+    match l1, l2 with
+    | [], l2 -> l2 @@ accu
+    | l1, [] -> l1 @@ accu
+    | h1::t1, h2::t2 ->
+        if cmp h1 h2 > 0
+        then rev_merge_rev t1 l2 (h1::accu)
+        else rev_merge_rev l1 t2 (h2::accu)
+  in
+  let rec sort n l =
+    match n, l with
+    | 2, x1 :: x2 :: _ ->
+       if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1]
+    | 3, x1 :: x2 :: x3 :: _ ->
+       if cmp x1 x2 <= 0 then begin
+         if cmp x2 x3 <= 0 then [x1; x2; x3]
+         else if cmp x1 x3 <= 0 then [x1; x3; x2]
+         else [x3; x1; x2]
+       end else begin
+         if cmp x1 x3 <= 0 then [x2; x1; x3]
+         else if cmp x2 x3 <= 0 then [x2; x3; x1]
+         else [x3; x2; x1]
+       end
+    | n, l ->
+       let n1 = n asr 1 in
+       let n2 = n - n1 in
+       rev_merge_rev (rev_sort n1 l) (rev_sort n2 (chop n1 l)) []
+  and rev_sort n l =
+    match n, l with
+    | 2, x1 :: x2 :: _ ->
+       if cmp x1 x2 > 0 then [x1; x2] else [x2; x1]
+    | 3, x1 :: x2 :: x3 :: _ ->
+       if cmp x1 x2 > 0 then begin
+         if cmp x2 x3 > 0 then [x1; x2; x3]
+         else if cmp x1 x3 > 0 then [x1; x3; x2]
+         else [x3; x1; x2]
+       end else begin
+         if cmp x1 x3 > 0 then [x2; x1; x3]
+         else if cmp x2 x3 > 0 then [x2; x3; x1]
+         else [x3; x2; x1]
+       end
+    | n, l ->
+       let n1 = n asr 1 in
+       let n2 = n - n1 in
+       rev_merge (sort n1 l) (sort n2 (chop n1 l)) []
+  in
+  let len = List.length l in
+  if len < 2 then l else sort len l
+;;
+
+
+(************************************************************************)
+(* merge sort on short lists a la Pottier, logarithmic stack space,
+   in place: input list is freed as the output is being computed. *)
+
+let rec chop k l =
+  if k = 0 then l else begin
+    match l with
+    | x::t -> chop (k-1) t
+    | _ -> assert false
+  end
+;;
+
+let lmerge_4e cmp l =
+  let rec rev_merge l1 l2 accu =
+    match l1, l2 with
+    | [], l2 -> l2 @@ accu
+    | l1, [] -> l1 @@ accu
+    | h1::t1, h2::t2 ->
+        if cmp h1 h2 <= 0
+        then rev_merge t1 l2 (h1::accu)
+        else rev_merge l1 t2 (h2::accu)
+  in
+  let rec rev_merge_rev l1 l2 accu =
+    match l1, l2 with
+    | [], l2 -> l2 @@ accu
+    | l1, [] -> l1 @@ accu
+    | h1::t1, h2::t2 ->
+        if cmp h1 h2 > 0
+        then rev_merge_rev t1 l2 (h1::accu)
+        else rev_merge_rev l1 t2 (h2::accu)
+  in
+  let rec sort n l =
+    match n, l with
+    | 2, x1 :: x2 :: _ ->
+       if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1]
+    | 3, x1 :: x2 :: x3 :: _ ->
+       if cmp x1 x2 <= 0 then begin
+         if cmp x2 x3 <= 0 then [x1; x2; x3]
+         else if cmp x1 x3 <= 0 then [x1; x3; x2]
+         else [x3; x1; x2]
+       end else begin
+         if cmp x1 x3 <= 0 then [x2; x1; x3]
+         else if cmp x2 x3 <= 0 then [x2; x3; x1]
+         else [x3; x2; x1]
+       end
+    | n, l ->
+       let n1 = n asr 1 in
+       let n2 = n - n1 in
+       let l2 = chop n1 l in
+       let s1 = rev_sort n1 l in
+       let s2 = rev_sort n2 l2 in
+       rev_merge_rev s1 s2 []
+  and rev_sort n l =
+    match n, l with
+    | 2, x1 :: x2 :: _ ->
+       if cmp x1 x2 > 0 then [x1; x2] else [x2; x1]
+    | 3, x1 :: x2 :: x3 :: _ ->
+       if cmp x1 x2 > 0 then begin
+         if cmp x2 x3 > 0 then [x1; x2; x3]
+         else if cmp x1 x3 > 0 then [x1; x3; x2]
+         else [x3; x1; x2]
+       end else begin
+         if cmp x1 x3 > 0 then [x2; x1; x3]
+         else if cmp x2 x3 > 0 then [x2; x3; x1]
+         else [x3; x2; x1]
+       end
+    | n, l ->
+       let n1 = n asr 1 in
+       let n2 = n - n1 in
+       let l2 = chop n1 l in
+       let s1 = sort n1 l in
+       let s2 = sort n2 l2 in
+       rev_merge s1 s2 []
+  in
+  let len = List.length l in
+  if len < 2 then l else sort len l
+;;
+
+(************************************************************************)
+(* chop-free version of Pottier's code, binary version *)
+
+let rec merge cmp l1 l2 =
+  match l1, l2 with
+  | [], l2 -> l2
+  | l1, [] -> l1
+  | h1 :: t1, h2 :: t2 ->
+      if cmp h1 h2 <= 0
+      then h1 :: merge cmp t1 l2
+      else h2 :: merge cmp l1 t2
+;;
+
+let lmerge_5a cmp l =
+  let rem = ref l in
+  let rec sort_prefix n =
+    if n <= 1 then begin
+      match !rem with
+      | [] -> []
+      | [x] as l -> rem := []; l
+      | x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x]
+    end else if !rem = [] then []
+    else begin
+      let l1 = sort_prefix (n-1) in
+      let l2 = sort_prefix (n-1) in
+      merge cmp l1 l2
+    end
+  in
+  let len = ref (List.length l) in
+  let i = ref 0 in
+  while !len > 0 do incr i; len := !len lsr 1; done;
+  sort_prefix !i
+;;
+
+(************************************************************************)
+(* chop-free version of Pottier's code, dichotomic version,
+   ground cases 1 & 2 *)
+
+let rec merge cmp l1 l2 =
+  match l1, l2 with
+  | [], l2 -> l2
+  | l1, [] -> l1
+  | h1 :: t1, h2 :: t2 ->
+      if cmp h1 h2 <= 0
+      then h1 :: merge cmp t1 l2
+      else h2 :: merge cmp l1 t2
+;;
+
+let lmerge_5b cmp l =
+  let rem = ref l in
+  let rec sort_prefix n =
+    match n, !rem with
+    | 1, x::t -> rem := t; [x]
+    | 2, x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x]
+    | n, _ ->
+       let n1 = n/2 in
+       let n2 = n - n1 in
+       let l1 = sort_prefix n1 in
+       let l2 = sort_prefix n2 in
+       merge cmp l1 l2
+  in
+  let len = List.length l in
+  if len <= 1 then l else sort_prefix len
+;;
+
+(************************************************************************)
+(* chop-free version of Pottier's code, dichotomic version,
+   ground cases 2 & 3 *)
+
+let rec merge cmp l1 l2 =
+  match l1, l2 with
+  | [], l2 -> l2
+  | l1, [] -> l1
+  | h1 :: t1, h2 :: t2 ->
+      if cmp h1 h2 <= 0
+      then h1 :: merge cmp t1 l2
+      else h2 :: merge cmp l1 t2
+;;
+
+let lmerge_5c cmp l =
+  let rem = ref l in
+  let rec sort_prefix n =
+    match n, !rem with
+    | 2, x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x]
+    | 3, x::y::z::t ->
+       rem := t;
+       if cmp x y <= 0 then
+         if cmp y z <= 0 then [x; y; z]
+         else if cmp x z <= 0 then [x; z; y]
+         else [z; x; y]
+       else
+         if cmp x z <= 0 then [y; x; z]
+         else if cmp y z <= 0 then [y; z; x]
+         else [z; y; x]
+    | n, _ ->
+       let n1 = n/2 in
+       let n2 = n - n1 in
+       let l1 = sort_prefix n1 in
+       let l2 = sort_prefix n2 in
+       merge cmp l1 l2
+  in
+  let len = List.length l in
+  if len <= 1 then l else sort_prefix len
+;;
+
+(************************************************************************)
+(* chop-free, ref-free version of Pottier's code, dichotomic version,
+   ground cases 2 & 3, modified merge *)
+
+let lmerge_5d cmp l =
+  let rec merge1 h1 t1 l2 =
+    match l2 with
+    | [] -> h1::t1
+    | h2 :: t2 ->
+        if cmp h1 h2 <= 0
+        then h1 :: merge2 t1 h2 t2
+        else h2 :: merge1 h1 t1 t2
+  and merge2 l1 h2 t2 =
+    match l1 with
+    | [] -> h2::t2
+    | h1 :: t1 ->
+        if cmp h1 h2 <= 0
+        then h1 :: merge2 t1 h2 t2
+        else h2 :: merge1 h1 t1 t2
+  in
+  let rec sort_prefix n l =
+    match n, l with
+    | 2, x::y::t -> ((if cmp x y <= 0 then [x;y] else [y;x]), t)
+    | 3, x::y::z::t ->
+       ((if cmp x y <= 0 then
+           if cmp y z <= 0 then [x; y; z]
+           else if cmp x z <= 0 then [x; z; y]
+           else [z; x; y]
+         else
+           if cmp x z <= 0 then [y; x; z]
+           else if cmp y z <= 0 then [y; z; x]
+           else [z; y; x]),
+        t)
+    | n, _ ->
+       let n1 = n/2 in
+       let n2 = n - n1 in
+       let (l1, rest1) = sort_prefix n1 l in
+       match sort_prefix n2 rest1 with
+       | (h2::t2, rest2) -> ((merge2 l1 h2 t2), rest2)
+       | _ -> assert false
+  in
+  let len = List.length l in
+  if len <= 1 then l else fst (sort_prefix len l)
+;;
+
+(************************************************************************)
+(* merge sort on arrays, merge with tail-rec function *)
+
+let amerge_1a cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        dst.(d) <- s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 a.(i1) i2 s2 (d + 1)
+        else
+          Array.blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        dst.(d) <- s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 src2.(i2) (d + 1)
+        else
+          Array.blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+  in
+  let rec sortto srcofs dst dstofs len =
+    assert (len > 0);
+    if len = 1 then dst.(dstofs) <- a.(srcofs)
+    else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = Array.length a in
+  if l <= 1 then ()
+  else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let amerge_1b cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        dst.(d) <- s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 a.(i1) i2 s2 (d + 1)
+        else
+          Array.blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        dst.(d) <- s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 src2.(i2) (d + 1)
+        else
+          Array.blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+  in
+  let rec sortto srcofs dst dstofs len =
+    assert (len > 0);
+    if len = 1 then dst.(dstofs) <- a.(srcofs)
+    else if len = 2 then begin
+      if cmp a.(srcofs) a.(srcofs+1) <= 0 then begin
+        dst.(dstofs) <- a.(srcofs);
+        dst.(dstofs+1) <- a.(srcofs+1);
+      end else begin
+        dst.(dstofs) <- a.(srcofs+1);
+        dst.(dstofs+1) <- a.(srcofs);
+      end;
+    end else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = Array.length a in
+  if l <= 1 then ()
+  else if l = 2 then begin
+    if cmp a.(0) a.(1) > 0 then begin
+      let e = a.(0) in
+      a.(0) <- a.(1);
+      a.(1) <- e;
+    end;
+  end else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 3;;
+let amerge_1c cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        dst.(d) <- s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 a.(i1) i2 s2 (d + 1)
+        else
+          Array.blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        dst.(d) <- s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 src2.(i2) (d + 1)
+        else
+          Array.blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = a.(srcofs + i) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 4;;
+let amerge_1d cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        dst.(d) <- s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 a.(i1) i2 s2 (d + 1)
+        else
+          Array.blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        dst.(d) <- s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 src2.(i2) (d + 1)
+        else
+          Array.blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = a.(srcofs + i) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 5;;
+let amerge_1e cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        dst.(d) <- s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 a.(i1) i2 s2 (d + 1)
+        else
+          Array.blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        dst.(d) <- s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 src2.(i2) (d + 1)
+        else
+          Array.blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = a.(srcofs + i) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 6;;
+let amerge_1f cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        dst.(d) <- s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 a.(i1) i2 s2 (d + 1)
+        else
+          Array.blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        dst.(d) <- s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 src2.(i2) (d + 1)
+        else
+          Array.blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = a.(srcofs + i) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 7;;
+let amerge_1g cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        dst.(d) <- s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 a.(i1) i2 s2 (d + 1)
+        else
+          Array.blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        dst.(d) <- s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 src2.(i2) (d + 1)
+        else
+          Array.blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = a.(srcofs + i) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 8;;
+let amerge_1h cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        dst.(d) <- s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 a.(i1) i2 s2 (d + 1)
+        else
+          Array.blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        dst.(d) <- s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 src2.(i2) (d + 1)
+        else
+          Array.blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = a.(srcofs + i) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 9;;
+let amerge_1i cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        dst.(d) <- s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 a.(i1) i2 s2 (d + 1)
+        else
+          Array.blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        dst.(d) <- s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 src2.(i2) (d + 1)
+        else
+          Array.blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = a.(srcofs + i) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 10;;
+let amerge_1j cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        dst.(d) <- s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 a.(i1) i2 s2 (d + 1)
+        else
+          Array.blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        dst.(d) <- s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 src2.(i2) (d + 1)
+        else
+          Array.blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = a.(srcofs + i) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+(* FIXME a essayer: *)
+(* list->array->list direct et array->list->array direct *)
+(* overhead = 1/3, 1/4, etc. *)
+(* overhead = sqrt (n) *)
+(* overhead = n/3 jusqu'a 30k, 30k jusqu'a 900M, sqrt (n) au-dela *)
+
+(************************************************************************)
+(* merge sort on arrays, merge with loop *)
+
+(* cutoff = 1 *)
+let amerge_3a cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let i1 = ref src1ofs
+    and i2 = ref src2ofs
+    and d = ref dstofs
+    and src1r = src1ofs + src1len
+    and src2r = src2ofs + src2len
+    in
+    while !i1 < src1r && !i2 < src2r do
+      let s1 = a.(!i1) and s2 = src2.(!i2) in
+      if cmp s1 s2 <= 0 then begin
+        dst.(!d) <- s1;
+        incr i1;
+      end else begin
+        dst.(!d) <- s2;
+        incr i2;
+      end;
+      incr d;
+    done;
+    if !i1 < src1r then
+      Array.blit a !i1 dst !d (src1r - !i1)
+    else
+      Array.blit src2 !i2 dst !d (src2r - !i2)
+  in
+  let rec sortto srcofs dst dstofs len =
+    assert (len > 0);
+    if len = 1 then dst.(dstofs) <- a.(srcofs) else
+    let l1 = len / 2 in
+    let l2 = len - l1 in
+    sortto (srcofs+l1) dst (dstofs+l1) l2;
+    sortto srcofs a (srcofs+l2) l1;
+    merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
+  in
+  let l = Array.length a in
+  if l <= 1 then () else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let amerge_3b cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let i1 = ref src1ofs
+    and i2 = ref src2ofs
+    and d = ref dstofs
+    and src1r = src1ofs + src1len
+    and src2r = src2ofs + src2len
+    in
+    while !i1 < src1r && !i2 < src2r do
+      let s1 = a.(!i1) and s2 = src2.(!i2) in
+      if cmp s1 s2 <= 0 then begin
+        dst.(!d) <- s1;
+        incr i1;
+      end else begin
+        dst.(!d) <- s2;
+        incr i2;
+      end;
+      incr d;
+    done;
+    if !i1 < src1r then
+      Array.blit a !i1 dst !d (src1r - !i1)
+    else
+      Array.blit src2 !i2 dst !d (src2r - !i2)
+  in
+  let rec sortto srcofs dst dstofs len =
+    assert (len > 0);
+    if len = 1 then dst.(dstofs) <- a.(srcofs)
+    else if len = 2 then begin
+      if cmp a.(srcofs) a.(srcofs+1) <= 0 then begin
+        dst.(dstofs) <- a.(srcofs);
+        dst.(dstofs+1) <- a.(srcofs+1);
+      end else begin
+        dst.(dstofs) <- a.(srcofs+1);
+        dst.(dstofs+1) <- a.(srcofs);
+      end
+    end else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs+l1) dst (dstofs+l1) l2;
+      sortto srcofs a (srcofs+l2) l1;
+      merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
+    end
+  in
+  let l = Array.length a in
+  if l <= 1 then ()
+  else if l = 2 then begin
+    if cmp a.(0) a.(1) > 0 then begin
+      let e = a.(0) in
+      a.(0) <- a.(1);
+      a.(1) <- e;
+    end;
+  end else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 3;;
+let amerge_3c cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let i1 = ref src1ofs
+    and i2 = ref src2ofs
+    and d = ref dstofs
+    and src1r = src1ofs + src1len
+    and src2r = src2ofs + src2len
+    in
+    while !i1 < src1r && !i2 < src2r do
+      let s1 = a.(!i1) and s2 = src2.(!i2) in
+      if cmp s1 s2 <= 0 then begin
+        dst.(!d) <- s1;
+        incr i1;
+      end else begin
+        dst.(!d) <- s2;
+        incr i2;
+      end;
+      incr d;
+    done;
+    if !i1 < src1r then
+      Array.blit a !i1 dst !d (src1r - !i1)
+    else
+      Array.blit src2 !i2 dst !d (src2r - !i2)
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len-1 do
+      let e = a.(srcofs+i) in
+      let j = ref (dstofs+i-1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else
+    let l1 = len / 2 in
+    let l2 = len - l1 in
+    sortto (srcofs+l1) dst (dstofs+l1) l2;
+    sortto srcofs a (srcofs+l2) l1;
+    merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 4;;
+let amerge_3d cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let i1 = ref src1ofs
+    and i2 = ref src2ofs
+    and d = ref dstofs
+    and src1r = src1ofs + src1len
+    and src2r = src2ofs + src2len
+    in
+    while !i1 < src1r && !i2 < src2r do
+      let s1 = a.(!i1) and s2 = src2.(!i2) in
+      if cmp s1 s2 <= 0 then begin
+        dst.(!d) <- s1;
+        incr i1;
+      end else begin
+        dst.(!d) <- s2;
+        incr i2;
+      end;
+      incr d;
+    done;
+    if !i1 < src1r then
+      Array.blit a !i1 dst !d (src1r - !i1)
+    else
+      Array.blit src2 !i2 dst !d (src2r - !i2)
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len-1 do
+      let e = a.(srcofs+i) in
+      let j = ref (dstofs+i-1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else
+    let l1 = len / 2 in
+    let l2 = len - l1 in
+    sortto (srcofs+l1) dst (dstofs+l1) l2;
+    sortto srcofs a (srcofs+l2) l1;
+    merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 5;;
+let amerge_3e cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let i1 = ref src1ofs
+    and i2 = ref src2ofs
+    and d = ref dstofs
+    and src1r = src1ofs + src1len
+    and src2r = src2ofs + src2len
+    in
+    while !i1 < src1r && !i2 < src2r do
+      let s1 = a.(!i1) and s2 = src2.(!i2) in
+      if cmp s1 s2 <= 0 then begin
+        dst.(!d) <- s1;
+        incr i1;
+      end else begin
+        dst.(!d) <- s2;
+        incr i2;
+      end;
+      incr d;
+    done;
+    if !i1 < src1r then
+      Array.blit a !i1 dst !d (src1r - !i1)
+    else
+      Array.blit src2 !i2 dst !d (src2r - !i2)
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len-1 do
+      let e = a.(srcofs+i) in
+      let j = ref (dstofs+i-1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else
+    let l1 = len / 2 in
+    let l2 = len - l1 in
+    sortto (srcofs+l1) dst (dstofs+l1) l2;
+    sortto srcofs a (srcofs+l2) l1;
+    merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 6;;
+let amerge_3f cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let i1 = ref src1ofs
+    and i2 = ref src2ofs
+    and d = ref dstofs
+    and src1r = src1ofs + src1len
+    and src2r = src2ofs + src2len
+    in
+    while !i1 < src1r && !i2 < src2r do
+      let s1 = a.(!i1) and s2 = src2.(!i2) in
+      if cmp s1 s2 <= 0 then begin
+        dst.(!d) <- s1;
+        incr i1;
+      end else begin
+        dst.(!d) <- s2;
+        incr i2;
+      end;
+      incr d;
+    done;
+    if !i1 < src1r then
+      Array.blit a !i1 dst !d (src1r - !i1)
+    else
+      Array.blit src2 !i2 dst !d (src2r - !i2)
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len-1 do
+      let e = a.(srcofs+i) in
+      let j = ref (dstofs+i-1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else
+    let l1 = len / 2 in
+    let l2 = len - l1 in
+    sortto (srcofs+l1) dst (dstofs+l1) l2;
+    sortto srcofs a (srcofs+l2) l1;
+    merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 7;;
+let amerge_3g cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let i1 = ref src1ofs
+    and i2 = ref src2ofs
+    and d = ref dstofs
+    and src1r = src1ofs + src1len
+    and src2r = src2ofs + src2len
+    in
+    while !i1 < src1r && !i2 < src2r do
+      let s1 = a.(!i1) and s2 = src2.(!i2) in
+      if cmp s1 s2 <= 0 then begin
+        dst.(!d) <- s1;
+        incr i1;
+      end else begin
+        dst.(!d) <- s2;
+        incr i2;
+      end;
+      incr d;
+    done;
+    if !i1 < src1r then
+      Array.blit a !i1 dst !d (src1r - !i1)
+    else
+      Array.blit src2 !i2 dst !d (src2r - !i2)
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len-1 do
+      let e = a.(srcofs+i) in
+      let j = ref (dstofs+i-1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else
+    let l1 = len / 2 in
+    let l2 = len - l1 in
+    sortto (srcofs+l1) dst (dstofs+l1) l2;
+    sortto srcofs a (srcofs+l2) l1;
+    merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 8;;
+let amerge_3h cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let i1 = ref src1ofs
+    and i2 = ref src2ofs
+    and d = ref dstofs
+    and src1r = src1ofs + src1len
+    and src2r = src2ofs + src2len
+    in
+    while !i1 < src1r && !i2 < src2r do
+      let s1 = a.(!i1) and s2 = src2.(!i2) in
+      if cmp s1 s2 <= 0 then begin
+        dst.(!d) <- s1;
+        incr i1;
+      end else begin
+        dst.(!d) <- s2;
+        incr i2;
+      end;
+      incr d;
+    done;
+    if !i1 < src1r then
+      Array.blit a !i1 dst !d (src1r - !i1)
+    else
+      Array.blit src2 !i2 dst !d (src2r - !i2)
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len-1 do
+      let e = a.(srcofs+i) in
+      let j = ref (dstofs+i-1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else
+    let l1 = len / 2 in
+    let l2 = len - l1 in
+    sortto (srcofs+l1) dst (dstofs+l1) l2;
+    sortto srcofs a (srcofs+l2) l1;
+    merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 9;;
+let amerge_3i cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let i1 = ref src1ofs
+    and i2 = ref src2ofs
+    and d = ref dstofs
+    and src1r = src1ofs + src1len
+    and src2r = src2ofs + src2len
+    in
+    while !i1 < src1r && !i2 < src2r do
+      let s1 = a.(!i1) and s2 = src2.(!i2) in
+      if cmp s1 s2 <= 0 then begin
+        dst.(!d) <- s1;
+        incr i1;
+      end else begin
+        dst.(!d) <- s2;
+        incr i2;
+      end;
+      incr d;
+    done;
+    if !i1 < src1r then
+      Array.blit a !i1 dst !d (src1r - !i1)
+    else
+      Array.blit src2 !i2 dst !d (src2r - !i2)
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len-1 do
+      let e = a.(srcofs+i) in
+      let j = ref (dstofs+i-1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else
+    let l1 = len / 2 in
+    let l2 = len - l1 in
+    sortto (srcofs+l1) dst (dstofs+l1) l2;
+    sortto srcofs a (srcofs+l2) l1;
+    merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+let cutoff = 10;;
+let amerge_3j cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let i1 = ref src1ofs
+    and i2 = ref src2ofs
+    and d = ref dstofs
+    and src1r = src1ofs + src1len
+    and src2r = src2ofs + src2len
+    in
+    while !i1 < src1r && !i2 < src2r do
+      let s1 = a.(!i1) and s2 = src2.(!i2) in
+      if cmp s1 s2 <= 0 then begin
+        dst.(!d) <- s1;
+        incr i1;
+      end else begin
+        dst.(!d) <- s2;
+        incr i2;
+      end;
+      incr d;
+    done;
+    if !i1 < src1r then
+      Array.blit a !i1 dst !d (src1r - !i1)
+    else
+      Array.blit src2 !i2 dst !d (src2r - !i2)
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len-1 do
+      let e = a.(srcofs+i) in
+      let j = ref (dstofs+i-1) in
+      while (!j >= dstofs && cmp dst.(!j) e > 0) do
+        dst.(!j + 1) <- dst.(!j);
+        decr j;
+      done;
+      dst.(!j + 1) <- e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else
+    let l1 = len / 2 in
+    let l2 = len - l1 in
+    sortto (srcofs+l1) dst (dstofs+l1) l2;
+    sortto srcofs a (srcofs+l2) l1;
+    merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs;
+  in
+  let l = Array.length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = Array.make l2 a.(0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
+
+(* FIXME essayer bottom-up merge on arrays ? *)
+
+(************************************************************************)
+(* Shell sort on arrays *)
+
+let ashell_1 cmp a =
+  let l = Array.length a in
+  let step = ref 1 in
+  while !step < l do step := !step * 3 + 1; done;
+  step := !step / 3;
+  while !step > 0 do
+    for j = !step to l-1 do
+      let e = a.(j) in
+      let k = ref (j - !step) in
+      let k1 = ref j in
+      while !k >= 0 && cmp a.(!k) e > 0 do
+        a.(!k1) <- a.(!k);
+        k1 := !k;
+        k := !k - !step;
+      done;
+      a.(!k1) <- e;
+    done;
+    step := !step / 3;
+  done;
+;;
+
+let ashell_2 cmp a =
+  let l = Array.length a in
+  let step = ref 1 in
+  while !step < l do step := !step * 3 + 1; done;
+  step := !step / 3;
+  while !step > 0 do
+    for j = !step to l-1 do
+      let e = a.(j) in
+      let k = ref (j - !step) in
+      while !k >= 0 && cmp a.(!k) e > 0 do
+        a.(!k + !step) <- a.(!k);
+        k := !k - !step;
+      done;
+      a.(!k + !step) <- e;
+    done;
+    step := !step / 3;
+  done;
+;;
+
+let ashell_3 cmp a =
+  let l = Array.length a in
+  let step = ref 1 in
+  while !step < l do step := !step * 3 + 1; done;
+  step := !step / 3;
+  while !step > 0 do
+    for i = 0 to !step - 1 do
+      let j = ref (i + !step) in
+      while !j < l do
+        let e = ref a.(!j) in
+        let k = ref (!j - !step) in
+        if cmp !e a.(i) < 0 then begin
+          let x = !e in e := a.(i); a.(i) <- x;
+        end;
+        while cmp a.(!k) !e > 0 do
+          a.(!k + !step) <- a.(!k);
+          k := !k - !step;
+        done;
+        a.(!k + !step) <- !e;
+        j := !j + !step;
+      done;
+    done;
+    step := !step / 3;
+  done;
+;;
+
+let force = Lazy.force;;
+
+type iilist = Cons of int * iilist Lazy.t;;
+
+let rec mult n (Cons (x,l)) = Cons (n*x, lazy (mult n (force l)))
+
+let rec merge (Cons (x1, t1) as l1) (Cons (x2, t2) as l2) =
+  if x1 = x2 then Cons (x1, lazy (merge (force t1) (force t2)))
+  else if x1 < x2 then Cons (x1, lazy (merge (force t1) l2))
+  else Cons (x2, lazy (merge l1 (force t2)))
+;;
+
+let rec scale = Cons (1, lazy (merge (mult 2 scale) (mult 3 scale)));;
+
+let ashell_4 cmp a =
+  let l = Array.length a in
+  let rec loop1 accu (Cons (x, t)) =
+    if x > l then accu else loop1 (x::accu) (force t)
+  in
+  let sc = loop1 [] scale in
+  let rec loop2 = function
+    | [] -> ()
+    | step::t ->
+      for i = 0 to step - 1 do
+        let j = ref (i + step) in
+        while !j < l do
+          let e = a.(!j) in
+          let k = ref (!j - step) in
+          while !k >= 0 && cmp a.(!k) e > 0 do
+            a.(!k + step) <- a.(!k);
+            k := !k - step;
+          done;
+          a.(!k + step) <- e;
+          j := !j + step;
+        done;
+      done;
+      loop2 t;
+  in
+  loop2 sc;
+;;
+
+(************************************************************************)
+(* Quicksort on arrays *)
+let cutoff = 1;;
+let aquick_1a cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
+    while !p2 <= !p3 do
+      let e = a.(!p3) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+      end else if c < 0 then begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- e;
+        incr p2;
+      end;
+    done;
+    incr p3;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 1 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 2;;
+let aquick_1b cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
+    while !p2 <= !p3 do
+      let e = a.(!p3) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+      end else if c < 0 then begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- e;
+        incr p2;
+      end;
+    done;
+    incr p3;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 1 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 3;;
+let aquick_1c cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
+    while !p2 <= !p3 do
+      let e = a.(!p3) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+      end else if c < 0 then begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- e;
+        incr p2;
+      end;
+    done;
+    incr p3;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 1 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 4;;
+let aquick_1d cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
+    while !p2 <= !p3 do
+      let e = a.(!p3) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+      end else if c < 0 then begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- e;
+        incr p2;
+      end;
+    done;
+    incr p3;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 1 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 5;;
+let aquick_1e cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
+    while !p2 <= !p3 do
+      let e = a.(!p3) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+      end else if c < 0 then begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- e;
+        incr p2;
+      end;
+    done;
+    incr p3;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 1 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 6;;
+let aquick_1f cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
+    while !p2 <= !p3 do
+      let e = a.(!p3) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+      end else if c < 0 then begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- e;
+        incr p2;
+      end;
+    done;
+    incr p3;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 1 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 7;;
+let aquick_1g cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in
+    while !p2 <= !p3 do
+      let e = a.(!p3) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+      end else if c < 0 then begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        a.(!p3) <- a.(!p2);
+        a.(!p2) <- e;
+        incr p2;
+      end;
+    done;
+    incr p3;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 1 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 1;;
+let aquick_2a cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        incr p2;
+      end;
+    done;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 2;;
+let aquick_2b cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        incr p2;
+      end;
+    done;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 3;;
+let aquick_2c cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        incr p2;
+      end;
+    done;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 4;;
+let aquick_2d cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        incr p2;
+      end;
+    done;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 5;;
+let aquick_2e cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        incr p2;
+      end;
+    done;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 6;;
+let aquick_2f cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        incr p2;
+      end;
+    done;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 7;;
+let aquick_2g cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end else begin
+        incr p2;
+      end;
+    done;
+    let len1 = !p1 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p1; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p1)
+      end else qsort l !p1
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 1;;
+let aquick_3a cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        incr p2;
+      end else begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end
+    done;
+    while !p1 > l do
+      decr p1;
+      decr p2;
+      let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
+    done;
+    let len1 = !p2 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p2; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p2)
+      end else qsort l !p2
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 2;;
+let aquick_3b cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        incr p2;
+      end else begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end
+    done;
+    while !p1 > l do
+      decr p1;
+      decr p2;
+      let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
+    done;
+    let len1 = !p2 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p2; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p2)
+      end else qsort l !p2
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 3;;
+let aquick_3c cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        incr p2;
+      end else begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end
+    done;
+    while !p1 > l do
+      decr p1;
+      decr p2;
+      let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
+    done;
+    let len1 = !p2 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p2; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p2)
+      end else qsort l !p2
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 4;;
+let aquick_3d cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        incr p2;
+      end else begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end
+    done;
+    while !p1 > l do
+      decr p1;
+      decr p2;
+      let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
+    done;
+    let len1 = !p2 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p2; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p2)
+      end else qsort l !p2
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 5;;
+let aquick_3e cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        incr p2;
+      end else begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end
+    done;
+    while !p1 > l do
+      decr p1;
+      decr p2;
+      let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
+    done;
+    let len1 = !p2 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p2; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p2)
+      end else qsort l !p2
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 6;;
+let aquick_3f cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        incr p2;
+      end else begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end
+    done;
+    while !p1 > l do
+      decr p1;
+      decr p2;
+      let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
+    done;
+    let len1 = !p2 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p2; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p2)
+      end else qsort l !p2
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 7;;
+let aquick_3g cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        incr p2;
+      end else begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end
+    done;
+    while !p1 > l do
+      decr p1;
+      decr p2;
+      let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
+    done;
+    let len1 = !p2 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p2; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p2)
+      end else qsort l !p2
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 8;;
+let aquick_3h cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        incr p2;
+      end else begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end
+    done;
+    while !p1 > l do
+      decr p1;
+      decr p2;
+      let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
+    done;
+    let len1 = !p2 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p2; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p2)
+      end else qsort l !p2
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 9;;
+let aquick_3i cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        incr p2;
+      end else begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end
+    done;
+    while !p1 > l do
+      decr p1;
+      decr p2;
+      let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
+    done;
+    let len1 = !p2 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p2; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p2)
+      end else qsort l !p2
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+let cutoff = 10;;
+let aquick_3j cmp a =
+  let rec qsort l r =     (* ASSUMES r - l >= 2 *)
+    let m = (l + r) / 2 in
+    let al = a.(l) and am = a.(m) and ar = a.(r - 1) in
+    let pivot = if cmp al am <= 0 then
+                  if cmp am ar <= 0 then am
+                  else if cmp al ar <= 0 then ar
+                  else al
+                else
+                  if cmp al ar <= 0 then al
+                  else if cmp am ar <= 0 then ar
+                  else am
+    in
+    let p1 = ref l and p2 = ref l and p3 = ref r in
+    while !p2 < !p3 do
+      let e = a.(!p2) in
+      let c = cmp e pivot in
+      if c > 0 then begin
+        decr p3;
+        a.(!p2) <- a.(!p3);
+        a.(!p3) <- e;
+      end else if c < 0 then begin
+        incr p2;
+      end else begin
+        a.(!p2) <- a.(!p1);
+        a.(!p1) <- e;
+        incr p1;
+        incr p2;
+      end
+    done;
+    while !p1 > l do
+      decr p1;
+      decr p2;
+      let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e;
+    done;
+    let len1 = !p2 - l and len2 = r - !p3 in
+    if len1 > cutoff then
+      if len2 > cutoff then begin
+        if len1 < len2
+        then (qsort l !p2; qsort !p3 r)
+        else (qsort !p3 r; qsort l !p2)
+      end else qsort l !p2
+    else if len2 > cutoff then qsort !p3 r;
+  in
+  let l = Array.length a in
+  if l > 1 then begin
+    qsort 0 l;
+    let mini = ref 0 in
+    for i = 0 to (min l cutoff) - 1 do
+      if cmp a.(i) a.(!mini) < 0 then mini := i;
+    done;
+    let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e;
+    for i = 1 to l - 1 do
+      let e = a.(i) in
+      let j = ref (i - 1) in
+      while cmp a.(!j) e > 0 do
+        a.(!j + 1) <- a.(!j);
+        decr j;
+      done;
+      a.(!j + 1) <- e;
+    done;
+  end;
+;;
+
+(************************************************************************)
+(* Heap sort on arrays (top-down, ternary) *)
+
+let aheap_1 cmp a =
+  let l = ref (Array.length a) in
+  let l3 = ref ((!l + 1) / 3) in   (* l3 is the first element without sons *)
+  let maxson i =                   (* ASSUMES i < !l3 *)
+    let i31 = i+i+i+1 in
+    let x = ref i31 in
+    if i31+2 < !l then begin
+      if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
+      if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
+      !x
+    end else begin
+      if i31+1 < !l && cmp a.(i31) a.(i31+1) < 0
+      then i31+1
+      else i31
+    end
+  in
+  let rec trickledown i e =    (* ASSUMES i < !l3 *)
+    let j = maxson i in
+    if cmp a.(j) e > 0 then begin
+      a.(i) <- a.(j);
+      if j < !l3 then trickledown j e else a.(j) <- e;
+    end else begin
+      a.(i) <- e;
+    end;
+  in
+  for i = !l3 - 1 downto 0 do trickledown i a.(i); done;
+  let m = ref (!l + 1 - 3 * !l3) in
+  while !l > 2 do
+    decr l;
+    if !m = 0 then (m := 2; decr l3) else decr m;
+    let e = a.(!l) in
+    a.(!l) <- a.(0);
+    trickledown 0 e;
+  done;
+  if !l > 1 then begin let e = a.(1) in a.(1) <- a.(0); a.(0) <- e; end;
+;;
+
+(************************************************************************)
+(* Heap sort on arrays (top-down, binary) *)
+
+(* FIXME essayer application partielle de trickledown (merge avec down) *)
+(* FIXME essayer expanser maxson dans trickledown; supprimer l'exception. *)
+
+let aheap_2 cmp a =
+  let maxson l i e =
+    let i21 = i + i + 1 in
+    if i21 + 1 < l && cmp a.(i21) a.(i21+1) < 0
+    then i21 + 1
+    else if i21 < l then i21 else (a.(i) <- e; raise Exit)
+  in
+  let rec trickledown l i e =
+    let j = maxson l i e in
+    if cmp a.(j) e > 0 then begin
+      a.(i) <- a.(j);
+      trickledown l j e;
+    end else begin
+      a.(i) <- e;
+    end;
+  in
+  let down l i e = try trickledown l i e with Exit -> () in
+  let l = Array.length a in
+  for i = l / 2 -1 downto 0 do down l i a.(i); done;
+  for i = l - 1 downto 1 do
+    let e = a.(i) in
+    a.(i) <- a.(0);
+    down i 0 e;
+  done;
+;;
+
+(************************************************************************)
+(* Heap sort on arrays (bottom-up, ternary) *)
+
+exception Bottom of int;;
+
+let aheap_3 cmp a =
+  let maxson l i =
+    let i31 = i+i+i+1 in
+    let x = ref i31 in
+    if i31+2 < l then begin
+      if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
+      if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
+      !x
+    end else
+      if i31+1 < l && cmp a.(i31) a.(i31+1) < 0
+      then i31+1
+      else if i31 < l then i31 else raise (Bottom i)
+  in
+  let rec trickledown l i e =
+    let j = maxson l i in
+    if cmp a.(j) e > 0 then begin
+      a.(i) <- a.(j);
+      trickledown l j e;
+    end else begin
+      a.(i) <- e;
+    end;
+  in
+  let rec trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in
+  let rec bubbledown l i =
+    let j = maxson l i in
+    a.(i) <- a.(j);
+    bubbledown l j;
+  in
+  let bubble l i = try bubbledown l i with Bottom i -> i in
+  let rec trickleup i e =
+    let father = (i - 1) / 3 in
+    assert (i <> father);
+    if cmp a.(father) e < 0 then begin
+      a.(i) <- a.(father);
+      if father > 0 then trickleup father e else a.(0) <- e;
+    end else begin
+      a.(i) <- e;
+    end;
+  in
+  let l = Array.length a in
+  for i = (l + 1) / 3 - 1 downto 0 do trickle l i a.(i); done;
+  for i = l - 1 downto 2 do
+    let e = a.(i) in
+    a.(i) <- a.(0);
+    trickleup (bubble i 0) e;
+  done;
+  if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
+;;
+
+(************************************************************************)
+(* Heap sort on arrays (bottom-up, binary) *)
+
+let aheap_4 cmp a =
+  let maxson l i =
+    let i21 = i + i + 1 in
+    if i21 + 1 < l && cmp a.(i21) a.(i21 + 1) < 0
+    then i21 + 1
+    else if i21 < l then i21 else raise (Bottom i)
+  in
+  let rec trickledown l i e =
+    let j = maxson l i in
+    if cmp a.(j) e > 0 then begin
+      a.(i) <- a.(j);
+      trickledown l j e;
+    end else begin
+      a.(i) <- e;
+    end;
+  in
+  let trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in
+  let rec bubbledown l i =
+    let j = maxson l i in
+    a.(i) <- a.(j);
+    bubbledown l j;
+  in
+  let bubble l i = try bubbledown l i with Bottom i -> i in
+  let rec trickleup i e =
+    let father = (i - 1) / 2 in
+    assert (i <> father);
+    if cmp a.(father) e < 0 then begin
+      a.(i) <- a.(father);
+      if father > 0 then trickleup father e else a.(0) <- e;
+    end else begin
+      a.(i) <- e;
+    end;
+  in
+  let l = Array.length a in
+  for i = l / 2 - 1 downto 0 do trickle l i a.(i); done;
+  for i = l - 1 downto 2 do
+    let e = a.(i) in
+    a.(i) <- a.(0);
+    trickleup (bubble i 0) e;
+  done;
+  if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
+;;
+
+(************************************************************************)
+(* heap sort, top-down, ternary, recursive final loop *)
+
+let aheap_5 cmp a =
+  let maxson l i =                 (* ASSUMES i < (l+1)/3 *)
+    let i31 = i+i+i+1 in
+    let x = ref i31 in
+    if i31+2 < l then begin
+      if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
+      if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
+      !x
+    end else begin
+      if i31+1 < l && cmp a.(i31) a.(i31+1) < 0
+      then i31+1
+      else i31
+    end
+  in
+  let rec trickledown l l3 i e =    (* ASSUMES i < l3 *)
+    let j = maxson l i in
+    if cmp a.(j) e > 0 then begin
+      a.(i) <- a.(j);
+      if j < l3 then trickledown l l3 j e else a.(j) <- e;
+    end else begin
+      a.(i) <- e;
+    end;
+  in
+  let l = Array.length a in
+  let l3 = (l + 1) / 3 in
+  for i = l3 - 1 downto 0 do trickledown l l3 i a.(i); done;
+  let rec loop0 l l3 =
+    let e = a.(l) in
+    a.(l) <- a.(0);
+    trickledown l l3 0 e;
+    loop2 (l-1) (l3-1);
+  and loop1 l l3 =
+    let e = a.(l) in
+    a.(l) <- a.(0);
+    trickledown l l3 0 e;
+    loop0 (l-1) l3;
+  and loop2 l l3 =
+    if l > 1 then begin
+      let e = a.(l) in
+      a.(l) <- a.(0);
+      trickledown l l3 0 e;
+      loop1 (l-1) l3;
+    end else begin
+      let e = a.(1) in a.(1) <- a.(0); a.(0) <- e;
+    end;
+  in
+  if l > 1 then
+    match l + 1 - 3 * l3 with
+    | 0 -> loop2 (l-1) (l3-1);
+    | 1 -> loop0 (l-1) l3;
+    | 2 -> loop1 (l-1) l3;
+    | _ -> assert false;
+;;
+
+(************************************************************************)
+(* heap sort, top-down, ternary, with exception *)
+
+let aheap_6 cmp a =
+  let maxson e l i =
+    let i31 = i + i + i + 1 in
+    let x = ref i31 in
+    if i31+2 < l then begin
+      if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
+      if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
+      !x
+    end else begin
+      if i31+1 < l && cmp a.(i31) a.(i31+1) < 0
+      then i31+1
+      else if i31 < l then i31 else (a.(i) <- e; raise Exit)
+    end
+  in
+  let rec trickledown e l i =
+    let j = maxson e l i in
+    if cmp a.(j) e > 0 then begin
+      a.(i) <- a.(j);
+      trickledown e l j;
+    end else begin
+      a.(i) <- e;
+    end;
+  in
+  let down e l i = try trickledown e l i with Exit -> (); in
+  let l = Array.length a in
+  for i = (l + 1) / 3 - 1 downto 0 do down a.(i) l i; done;
+  for i = l - 1 downto 2 do
+    let e = a.(i) in
+    a.(i) <- a.(0);
+    down e i 0;
+  done;
+  if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
+;;
+
+(* FIXME essayer cutoff pour heapsort *)
+
+(************************************************************************)
+(* Insertion sort with dichotomic search *)
+
+let ainsertion_1 cmp a =
+  let rec dicho l r e =
+    if l = r then l else begin
+      let m = (l + r) / 2 in
+      if cmp a.(m) e <= 0
+      then dicho (m+1) r e
+      else dicho l m e
+    end
+  in
+  for i = 1 to Array.length a - 1 do
+    let e = a.(i) in
+    let j = dicho 0 i e in
+    Array.blit a j a (j + 1) (i - j);
+    a.(j) <- e;
+  done;
+;;
+
+(************************************************************************)
+(* merge sort on lists via arrays *)
+
+let array_to_list_in_place a =
+  let l = Array.length a in
+  let rec loop accu n p =
+    if p <= 0 then accu else begin
+      if p = n then begin
+        Obj.truncate (Obj.repr a) p;
+        loop (a.(p-1) :: accu) (n-1000) (p-1)
+      end else begin
+        loop (a.(p-1) :: accu) n (p-1)
+      end
+    end
+  in
+  loop [] l l
+;;
+
+let array_of_list l len =
+  match l with
+  | [] -> [| |]
+  | h::t ->
+      let a = Array.make len h in
+      let rec loop i l =
+        match l with
+        | [] -> ()
+        | h::t -> a.(i) <- h; loop (i+1) t
+      in
+      loop 1 t;
+      a
+;;
+
+let lmerge_0a cmp l =
+  let a = Array.of_list l in
+  amerge_1e cmp a;
+  array_to_list_in_place a
+;;
+
+let lmerge_0b cmp l =
+  let len = List.length l in
+  if len > 256 then Gc.minor ();
+  let a = array_of_list l len in
+  amerge_1e cmp a;
+  array_to_list_in_place a
+;;
+
+let lshell_0 cmp l =
+  let a = Array.of_list l in
+  ashell_2 cmp a;
+  array_to_list_in_place a
+;;
+
+let lquick_0 cmp l =
+  let a = Array.of_list l in
+  aquick_3f cmp a;
+  array_to_list_in_place a
+;;
+
+(************************************************************************)
+(* merge sort on arrays via lists *)
+
+let amerge_0 cmp a =    (* cutoff is not yet used *)
+  let l = lmerge_4e cmp (Array.to_list a) in
+  let rec loop i = function
+  | [] -> ()
+  | h::t -> a.(i) <- h; loop (i + 1) t
+  in
+  loop 0 l
+;;
+
+(************************************************************************)
+
+let lold = [
+  "Sort.list", Sort.list, true;
+  "lmerge_3", lmerge_3, false;
+  "lmerge_4a", lmerge_4a, true;
+];;
+
+let lnew = [
+  "List.stable_sort", List.stable_sort, true;
+
+  "lmerge_0a", lmerge_0a, true;
+  "lmerge_0b", lmerge_0b, true;
+  "lshell_0", lshell_0, false;
+  "lquick_0", lquick_0, false;
+
+  "lmerge_1a", lmerge_1a, true;
+  "lmerge_1b", lmerge_1b, true;
+  "lmerge_1c", lmerge_1c, true;
+  "lmerge_1d", lmerge_1d, true;
+
+  "lmerge_4b", lmerge_4b, true;
+  "lmerge_4c", lmerge_4c, true;
+  "lmerge_4d", lmerge_4d, true;
+  "lmerge_4e", lmerge_4e, true;
+
+  "lmerge_5a", lmerge_5a, true;
+  "lmerge_5b", lmerge_5b, true;
+  "lmerge_5c", lmerge_5c, true;
+  "lmerge_5d", lmerge_5d, true;
+];;
+let anew = [
+  "Array.stable_sort", Array.stable_sort, true;
+  "Array.sort", Array.sort, false;
+
+  "amerge_0", amerge_0, true;
+
+  "amerge_1a", amerge_1a, true;
+  "amerge_1b", amerge_1b, true;
+  "amerge_1c", amerge_1c, true;
+  "amerge_1d", amerge_1d, true;
+  "amerge_1e", amerge_1e, true;
+  "amerge_1f", amerge_1f, true;
+  "amerge_1g", amerge_1g, true;
+  "amerge_1h", amerge_1h, true;
+  "amerge_1i", amerge_1i, true;
+  "amerge_1j", amerge_1j, true;
+
+  "amerge_3a", amerge_3a, true;
+  "amerge_3b", amerge_3b, true;
+  "amerge_3c", amerge_3c, true;
+  "amerge_3d", amerge_3d, true;
+  "amerge_3e", amerge_3e, true;
+  "amerge_3f", amerge_3f, true;
+  "amerge_3g", amerge_3g, true;
+  "amerge_3h", amerge_3h, true;
+  "amerge_3i", amerge_3i, true;
+  "amerge_3j", amerge_3j, true;
+
+  "ashell_1", ashell_1, false;
+  "ashell_2", ashell_2, false;
+  "ashell_3", ashell_3, false;
+  "ashell_4", ashell_4, false;
+
+  "aquick_1a", aquick_1a, false;
+  "aquick_1b", aquick_1b, false;
+  "aquick_1c", aquick_1c, false;
+  "aquick_1d", aquick_1d, false;
+  "aquick_1e", aquick_1e, false;
+  "aquick_1f", aquick_1f, false;
+  "aquick_1g", aquick_1g, false;
+
+  "aquick_2a", aquick_2a, false;
+  "aquick_2b", aquick_2b, false;
+  "aquick_2c", aquick_2c, false;
+  "aquick_2d", aquick_2d, false;
+  "aquick_2e", aquick_2e, false;
+  "aquick_2f", aquick_2f, false;
+  "aquick_2g", aquick_2g, false;
+
+  "aquick_3a", aquick_3a, false;
+  "aquick_3b", aquick_3b, false;
+  "aquick_3c", aquick_3c, false;
+  "aquick_3d", aquick_3d, false;
+  "aquick_3e", aquick_3e, false;
+  "aquick_3f", aquick_3f, false;
+  "aquick_3g", aquick_3g, false;
+  "aquick_3h", aquick_3h, false;
+  "aquick_3i", aquick_3i, false;
+  "aquick_3j", aquick_3j, false;
+
+  "aheap_1", aheap_1, false;
+  "aheap_2", aheap_2, false;
+  "aheap_3", aheap_3, false;
+  "aheap_4", aheap_4, false;
+  "aheap_5", aheap_5, false;
+  "aheap_6", aheap_6, false;
+
+  "ainsertion_1", ainsertion_1, true;
+];;
+
+(************************************************************************)
+(* main program *)
+
+type mode = Test_std | Test | Bench1 | Bench2 | Bench3;;
+
+let size = ref 22
+and mem = ref 0
+and mode = ref Test_std
+and only = ref []
+;;
+
+let usage = "Usage: sorts [-size <table size>] [-mem <memory size>]\n\
+          \032            [-seed <random seed>] [-test|-bench]"
+;;
+
+let options = [
+  "-size", Arg.Int ((:=) size), "   Maximum size for benchmarks (default 22)";
+  "-meg",Arg.Int ((:=) mem),"    How many megabytes to preallocate (default 0)";
+  "-seed", Arg.Int ((:=) seed), "   PRNG seed (default 0)";
+  "-teststd", Arg.Unit (fun () -> mode := Test_std), "   Test stdlib (default)";
+  "-test", Arg.Unit (fun () -> mode := Test), "   Select test mode";
+  "-bench1", Arg.Unit (fun () -> mode := Bench1), "  Select bench mode 1";
+  "-bench2", Arg.Unit (fun () -> mode := Bench2), "  Select bench mode 2";
+  "-bench3", Arg.Unit (fun () -> mode := Bench3), "  Select bench mode 3";
+  "-fn", Arg.String (fun x -> only := x :: !only),
+                         " <function>  Test/Bench this function (default all)";
+];;
+let anonymous x = raise (Arg.Bad ("unrecognised option "^x));;
+
+let main () =
+  Arg.parse options anonymous usage;
+
+  Printf.printf "Command line arguments are:";
+  for i = 1 to Array.length Sys.argv - 1 do
+    Printf.printf " %s" Sys.argv.(i);
+  done;
+  Printf.printf "\n";
+
+  ignore (String.create (1048576 * !mem));
+  Gc.full_major ();
+  let a2l = Array.to_list in
+  let l2ak x y = Array.of_list x in
+  let id = fun x -> x in
+  let fst x y = x in
+  let snd x y = y in
+  let benchonly f x y z t =
+    match !only with
+    | [] -> f x y z t
+    | l -> if List.mem y l then f x y z t
+  in
+  let testonly x1 x2 x3 x4 x5 x6 =
+    match !only with
+    | [] -> test x1 x2 x3 x4 x5 x6
+    | l -> if List.mem x1 l then test x1 x2 x3 x4 x5 x6
+  in
+
+  match !mode with
+  | Test_std -> begin
+      testonly "List.sort" false List.sort List.sort lc lc;
+      testonly "List.stable_sort" true List.stable_sort List.stable_sort lc lc;
+      testonly "Array.sort" false Array.sort Array.sort ac ac;
+      testonly "Array.stable_sort" true Array.stable_sort Array.stable_sort
+               ac ac;
+      printf "Number of tests failed: %d\n" !numfailed;
+    end;
+  | Test -> begin
+      for i = 0 to List.length lold - 1 do
+        let (name, f1, stable) = List.nth lold i in
+        let (_, f2, _) = List.nth lold i in
+        testonly name stable f1 f2 ll ll;
+      done;
+      testonly "Sort.array" false Sort.array Sort.array al al;
+      for i = 0 to List.length lnew - 1 do
+        let (name, f1, stable) = List.nth lnew i in
+        let (_, f2, _) = List.nth lnew i in
+        testonly name stable f1 f2 lc lc;
+      done;
+      for i = 0 to List.length anew - 1 do
+        let (name, f1, stable) = List.nth anew i in
+        let (_, f2, _) = List.nth anew i in
+        testonly name stable f1 f2 ac ac;
+      done;
+      printf "Number of tests failed: %d\n" !numfailed;
+    end;
+  | Bench1 -> begin
+      let ba = fun x y z -> benchonly bench1a !size x y z
+      and bb = fun x y z -> benchonly bench1b !size x y z
+      and bc = fun x y z -> benchonly bench1c !size x y z
+      in
+      for i = 0 to List.length lold - 1 do
+        let (name, f, stable) = List.nth lold i in ba name f ll;
+        let (name, f, stable) = List.nth lold i in bb name f ll;
+        let (name, f, stable) = List.nth lold i in bc name f ll;
+      done;
+      ba "Sort.array" Sort.array al;
+      bb "Sort.array" Sort.array al;
+      bc "Sort.array" Sort.array al;
+      for i = 0 to List.length lnew - 1 do
+        let (name, f, stable) = List.nth lnew i in ba name f lc;
+        let (name, f, stable) = List.nth lnew i in bb name f lc;
+        let (name, f, stable) = List.nth lnew i in bc name f lc;
+      done;
+      for i = 0 to List.length anew - 1 do
+        let (name, f, stable) = List.nth anew i in ba name f ac;
+        let (name, f, stable) = List.nth anew i in bb name f ac;
+        let (name, f, stable) = List.nth anew i in bc name f ac;
+      done;
+    end;
+  | Bench2 -> begin
+      let b = fun x y z -> benchonly bench2 !size x y z in
+      for i = 0 to List.length lold - 1 do
+        let (name, f, stable) = List.nth lold i in b name f ll;
+      done;
+      b "Sort.array" Sort.array al;
+      for i = 0 to List.length lnew - 1 do
+        let (name, f, stable) = List.nth lnew i in b name f lc;
+      done;
+      for i = 0 to List.length anew - 1 do
+        let (name, f, stable) = List.nth anew i in b name f ac;
+      done;
+    end;
+  | Bench3 -> begin
+      let ba = fun x y z -> benchonly bench3a !size x y z
+      and bb = fun x y z -> benchonly bench3b !size x y z
+      and bc = fun x y z -> benchonly bench3c !size x y z
+      in
+      for i = 0 to List.length lold - 1 do
+        let (name, f, stable) = List.nth lold i in ba name f ll;
+        let (name, f, stable) = List.nth lold i in bb name f ll;
+        let (name, f, stable) = List.nth lold i in bc name f ll;
+      done;
+      for i = 0 to List.length lnew - 1 do
+        let (name, f, stable) = List.nth lnew i in ba name f lc;
+        let (name, f, stable) = List.nth lnew i in bb name f lc;
+        let (name, f, stable) = List.nth lnew i in bc name f lc;
+      done;
+    end;
+;;
+
+if not !Sys.interactive then Printexc.catch main ();;
+
+(* $Id: sorts.ml,v 1.1 2002/06/26 14:55:36 doligez Exp $ *)
diff --git a/test/takc.ml b/test/takc.ml
new file mode 100644
index 00000000..6e7b647c
--- /dev/null
+++ b/test/takc.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: takc.ml,v 1.4 1999/11/17 18:58:35 xleroy Exp $ *)
+
+let rec tak x y z =
+  if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)
+           else z
+
+let rec repeat n =
+  if n <= 0 then 0 else tak 18 12 6 + repeat(n-1)
+
+let _ = print_int (repeat 50); print_newline(); exit 0
+
diff --git a/test/taku.ml b/test/taku.ml
new file mode 100644
index 00000000..055e420e
--- /dev/null
+++ b/test/taku.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: taku.ml,v 1.4 1999/11/17 18:58:35 xleroy Exp $ *)
+
+let rec tak (x, y, z) =
+  if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
+           else z
+
+let rec repeat n =
+  if n <= 0 then 0 else tak(18,12,6) + repeat(n-1)
+
+let _ = print_int (repeat 50); print_newline(); exit 0
diff --git a/test/testinterp/.cvsignore b/test/testinterp/.cvsignore
new file mode 100644
index 00000000..fdffd0fa
--- /dev/null
+++ b/test/testinterp/.cvsignore
@@ -0,0 +1,3 @@
+a.out
+ocamlrun.68k
+ocamlrun.ppc
diff --git a/otherlibs/graph/Makefile.Mac b/test/testinterp/addbytecode.mpw
similarity index 51%
rename from otherlibs/graph/Makefile.Mac
rename to test/testinterp/addbytecode.mpw
index f47734e4..fbb72c4e 100644
--- a/otherlibs/graph/Makefile.Mac
+++ b/test/testinterp/addbytecode.mpw
@@ -6,35 +6,37 @@
 #                                                                       #
 #   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.   #
+#   under the terms of the Q Public License version 1.0.                #
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.Mac,v 1.4 2001/12/07 13:39:52 xleroy Exp $
+# $Id: addbytecode.mpw,v 1.2 1999/11/29 19:04:15 doligez Exp $
 
-CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib:
+set echo 0
 
-all Ä graphics.cmi graphics.cma
-    set status 0
+Set f "`Files -f -q "{1}"`"         # get full pathnames
 
-graphics.cma Ä graphics.cmo
-    {CAMLC} -a -o graphics.cma graphics.cmo
+exit if `evaluate "{f}" =~ /(Å)¨0.ml/` != 1
+set base "{¨0}"
 
-partialclean Ä
-    delete -i Å.cm[aio] || set status 0
+set _closeit 0
+Set _openWindows " ``Windows -q`` "
+If "{_openWindows}" !~ /Å [¶']*"{f}"[¶']* Å/
+  Open "{f}"
+  Set _closeit 1
+End
 
-clean Ä partialclean
-    set status 0
+ocamlc -unsafe -nopervasives "{f}"
+find ° "{f}"
+find Æ\'**)'\:\'(**'\Æ "{f}"
+echo >"{f}".¤
+ocamldumpobj a.out >>"{f}".¤
+find ¥ "{f}"
 
-install Ä
-    duplicate -y graphics.cm[ia] graphics.mli "{LIBDIR}"
+format -t 8 "{f}"
 
-.cmi Ä .mli
-    {CAMLC} -c {default}.mli
+delete -i "{base}".cmi "{base}".cmo
 
-.cmo Ä .ml
-    {CAMLC} -c {default}.ml
-
-depend Ä
-    :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml > Makefile.Mac.depend
+if {_closeit}
+  close -y "{f}"
+end
diff --git a/test/testinterp/coverage b/test/testinterp/coverage
new file mode 100644
index 00000000..30a32439
--- /dev/null
+++ b/test/testinterp/coverage
@@ -0,0 +1,133 @@
+ACC0:                 090
+ACC1:                 090
+ACC2:                 090
+ACC3:                 090
+ACC4:                 090
+ACC5:                 090
+ACC6:                 090
+ACC7:                 090
+ACC:                  091
+PUSH:                 150
+PUSHACC0:             092
+PUSHACC1:             092
+PUSHACC2:             092
+PUSHACC3:             092
+PUSHACC4:             092
+PUSHACC5:             092
+PUSHACC6:             092
+PUSHACC7:             092
+PUSHACC:              093
+POP:                  020
+ASSIGN:               220
+ENVACC1:              170
+ENVACC2:              170
+ENVACC3:              170
+ENVACC4:              170
+ENVACC:               171
+PUSHENVACC1:          172
+PUSHENVACC2:          172
+PUSHENVACC3:          172
+PUSHENVACC4:          172
+PUSHENVACC:           173
+PUSH_RETADDR:         270
+APPLY:                165
+APPLY1:               161
+APPLY2:               164
+APPLY3:               164
+APPTERM:              181
+APPTERM1:             180
+APPTERM2:             180
+APPTERM3:             180
+RETURN:               162
+RESTART:              163
+GRAB:                 163
+CLOSURE:              160
+CLOSUREREC:           250
+OFFSETCLOSUREM2:      253
+OFFSETCLOSURE0:       253
+OFFSETCLOSURE2:       253
+OFFSETCLOSURE:        254
+PUSHOFFSETCLOSUREM2:  251
+PUSHOFFSETCLOSURE0:   251
+PUSHOFFSETCLOSURE2:   251
+PUSHOFFSETCLOSURE:    252
+GETGLOBAL:            050
+PUSHGETGLOBAL:        050
+GETGLOBALFIELD:       051
+PUSHGETGLOBALFIELD:   051
+SETGLOBAL:            000
+ATOM0:                000
+ATOM:                 
+PUSHATOM0:            
+PUSHATOM:             
+MAKEBLOCK:            041
+MAKEBLOCK1:           040
+MAKEBLOCK2:           040
+MAKEBLOCK3:           040
+MAKEFLOATBLOCK:       190
+GETFIELD0:            200
+GETFIELD1:            200
+GETFIELD2:            200
+GETFIELD3:            200
+GETFIELD:             201
+GETFLOATFIELD:        192
+SETFIELD0:            210
+SETFIELD1:            210
+SETFIELD2:            210
+SETFIELD3:            210
+SETFIELD:             211
+SETFLOATFIELD:        193
+VECTLENGTH:           130,191
+GETVECTITEM:          130
+SETVECTITEM:          131
+GETSTRINGCHAR:        120
+SETSTRINGCHAR:        121
+BRANCH:               070
+BRANCHIF:             070
+BRANCHIFNOT:          070
+SWITCH:               140,141,142
+BOOLNOT:              071
+PUSHTRAP:             100
+POPTRAP:              101
+RAISE:                060
+CHECK_SIGNALS:        230
+C_CALL1:              240
+C_CALL2:              240
+C_CALL3:              240
+C_CALL4:              240
+C_CALL5:              240
+C_CALLN:              
+CONST0:               010
+CONST1:               010
+CONST2:               010
+CONST3:               010
+CONSTINT:             011
+PUSHCONST0:           020
+PUSHCONST1:           021
+PUSHCONST2:           021
+PUSHCONST3:           021
+PUSHCONSTINT:         022
+NEGINT:               110
+ADDINT:               110
+SUBINT:               110
+MULINT:               110
+DIVINT:               110
+MODINT:               110
+ANDINT:               110
+ORINT:                110
+XORINT:               110
+LSLINT:               110
+LSRINT:               110
+ASRINT:               110
+EQ:                   080
+NEQ:                  080
+LTINT:                080
+LEINT:                080
+GTINT:                080
+GEINT:                080
+OFFSETINT:            110
+OFFSETREF:            260
+GETMETHOD:            300
+STOP:                 000
+EVENT:                
+BREAK:                
diff --git a/test/testinterp/lib.ml b/test/testinterp/lib.ml
new file mode 100644
index 00000000..caf44fb8
--- /dev/null
+++ b/test/testinterp/lib.ml
@@ -0,0 +1,46 @@
+(* file $Id: lib.ml,v 1.2 2004/04/06 09:11:45 starynke Exp $ *)
+
+external raise : exn -> 'a = "%raise"
+
+external not : bool -> bool = "%boolnot"
+
+external (=) : 'a -> 'a -> bool = "%equal"
+external (<>) : 'a -> 'a -> bool = "%notequal"
+external (<) : 'a -> 'a -> bool = "%lessthan"
+external (>) : 'a -> 'a -> bool = "%greaterthan"
+external (<=) : 'a -> 'a -> bool = "%lessequal"
+external (>=) : 'a -> 'a -> bool = "%greaterequal"
+
+external (~-) : int -> int = "%negint"
+external (+) : int -> int -> int = "%addint"
+external (-) : int -> int -> int = "%subint"
+external ( * ) : int -> int -> int = "%mulint"
+external (/) : int -> int -> int = "%divint"
+external (mod) : int -> int -> int = "%modint"
+
+external (land) : int -> int -> int = "%andint"
+external (lor) : int -> int -> int = "%orint"
+external (lxor) : int -> int -> int = "%xorint"
+external (lsl) : int -> int -> int = "%lslint"
+external (lsr) : int -> int -> int = "%lsrint"
+external (asr) : int -> int -> int = "%asrint"
+
+external ignore : 'a -> unit = "%ignore"
+
+type 'a ref = { mutable contents: 'a }
+external ref : 'a -> 'a ref = "%makemutable"
+external (!) : 'a ref -> 'a = "%field0"
+external (:=) : 'a ref -> 'a -> unit = "%setfield0"
+external incr : int ref -> unit = "%incr"
+external decr : int ref -> unit = "%decr"
+
+type 'a option = None | Some of 'a
+
+type 'a weak_t;;
+external weak_create: int -> 'a weak_t = "caml_weak_create";;
+external weak_set : 'a weak_t -> int -> 'a option -> unit = "caml_weak_set";;
+external weak_get: 'a weak_t -> int -> 'a option = "caml_weak_get";;
+
+let x = 42;;
+
+(* eof $Id: lib.ml,v 1.2 2004/04/06 09:11:45 starynke Exp $ *)
diff --git a/test/testinterp/no68k.rez b/test/testinterp/no68k.rez
new file mode 100644
index 00000000..a6353ea6
--- /dev/null
+++ b/test/testinterp/no68k.rez
@@ -0,0 +1 @@
+data 'CODE' (0) { };
diff --git a/test/testinterp/noppc.rez b/test/testinterp/noppc.rez
new file mode 100644
index 00000000..ecb9655f
--- /dev/null
+++ b/test/testinterp/noppc.rez
@@ -0,0 +1 @@
+data 'cfrg' (0) { };
diff --git a/test/testinterp/runtest.mpw b/test/testinterp/runtest.mpw
new file mode 100644
index 00000000..f6ee2bd6
--- /dev/null
+++ b/test/testinterp/runtest.mpw
@@ -0,0 +1,105 @@
+#########################################################################
+#                                                                       #
+#                            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: runtest.mpw,v 1.3 2000/01/07 13:36:21 doligez Exp $
+
+# usage: runtest.mpw [-bc] [-run <runtime>] [-start <n>] <file>É
+
+set echo 0
+
+exit if {#} < 1
+
+set dobytecode 0
+set dorun 0
+set start 0
+
+loop
+  if "{1}" == "-bc"
+    set dobytecode 1
+  else if "{1}" == "-run"
+    set dorun 1
+    set runtime "{2}"
+    shift
+  else if "{1}" == "-start"
+    if "{2}" =~ /0*([0-9]+)¨0/
+      shift
+      set start {¨0}
+    else
+      echo "### runtest.mpw: option "-start" expects a number as argument" > dev:stderr
+      exit 2
+    end
+  else
+    break
+  end
+  shift
+end
+
+set _camlrunparam "{camlrunparam}"
+
+loop
+  break if {#} == 0
+  if "{1}" !~ /(t0*([0-9]+)¨1Å)¨0.ml/
+    shift
+    continue
+  end
+  set base "{¨0}"
+
+  if {¨1} < {start}
+    shift
+    continue
+  end
+
+  if {¨1} >= 300
+    set libs "lib.ml stdlib.cma"
+  else if {¨1} >= 51
+    set libs "lib.ml"
+  else
+    set libs ""
+  end
+
+  set -e camlrunparam v=0
+  ocamlc -unsafe -nopervasives {libs} "{1}" || (shift; continue)
+
+  if {dobytecode}
+    Set f "`Files -f -q "{1}"`"         # get full pathnames
+    Set _openWindows " ``Windows -q`` "
+    If "{_openWindows}" !~ /Å [¶']*"{f}"[¶']* Å/
+      Open "{f}"
+      Set _closeit 1
+    else
+      set _closeit 0
+    End
+
+    find ° "{f}"
+    find Æ\'**)'\:\'(**'\Æ "{f}"
+    echo >"{f}".¤
+    ocamldumpobj a.out >>"{f}".¤
+    find ¥ "{f}"
+
+    if {_closeit}
+      close -y "{f}"
+    end
+  end
+
+  if {dorun}
+    set -e camlrunparam "{_camlrunparam}"
+    echo "{runtime} :a.out  ### testing {1}"
+    "{runtime}" :a.out || if "{1}" != "t060-raise.ml"; exit 3; end
+    echo "### done"
+  end
+
+  delete -i "{base}".cmi "{base}".cmo
+
+  shift
+end
+
+set -e camlrunparam "{_camlrunparam}"
diff --git a/test/testinterp/t000.ml b/test/testinterp/t000.ml
new file mode 100644
index 00000000..fafa1c89
--- /dev/null
+++ b/test/testinterp/t000.ml
@@ -0,0 +1,7 @@
+(* empty file *)
+
+(**
+       0 ATOM0 
+       1 SETGLOBAL T000
+       3 STOP 
+**)
diff --git a/test/testinterp/t010-const0.ml b/test/testinterp/t010-const0.ml
new file mode 100644
index 00000000..73ecbb1f
--- /dev/null
+++ b/test/testinterp/t010-const0.ml
@@ -0,0 +1,8 @@
+0;;
+
+(**
+       0 CONST0 
+       1 ATOM0 
+       2 SETGLOBAL T010-const0
+       4 STOP 
+**)
diff --git a/test/testinterp/t010-const1.ml b/test/testinterp/t010-const1.ml
new file mode 100644
index 00000000..75a00d57
--- /dev/null
+++ b/test/testinterp/t010-const1.ml
@@ -0,0 +1,8 @@
+1;;
+
+(**
+       0 CONST1 
+       1 ATOM0 
+       2 SETGLOBAL T010-const1
+       4 STOP 
+**)
diff --git a/test/testinterp/t010-const2.ml b/test/testinterp/t010-const2.ml
new file mode 100644
index 00000000..f0ed8e7d
--- /dev/null
+++ b/test/testinterp/t010-const2.ml
@@ -0,0 +1,8 @@
+2;;
+
+(**
+       0 CONST2 
+       1 ATOM0 
+       2 SETGLOBAL T010-const2
+       4 STOP 
+**)
diff --git a/test/testinterp/t010-const3.ml b/test/testinterp/t010-const3.ml
new file mode 100644
index 00000000..4f034c4b
--- /dev/null
+++ b/test/testinterp/t010-const3.ml
@@ -0,0 +1,8 @@
+3;;
+
+(**
+       0 CONST3 
+       1 ATOM0 
+       2 SETGLOBAL T010-const3
+       4 STOP 
+**)
diff --git a/test/testinterp/t011-constint.ml b/test/testinterp/t011-constint.ml
new file mode 100644
index 00000000..9ece6c53
--- /dev/null
+++ b/test/testinterp/t011-constint.ml
@@ -0,0 +1,8 @@
+4;;
+
+(**
+       0 CONSTINT 4
+       2 ATOM0 
+       3 SETGLOBAL T011-constint
+       5 STOP 
+**)
diff --git a/test/testinterp/t020.ml b/test/testinterp/t020.ml
new file mode 100644
index 00000000..5d6a3cfc
--- /dev/null
+++ b/test/testinterp/t020.ml
@@ -0,0 +1,10 @@
+let _ = () in ();;
+
+(**
+       0 CONST0 
+       1 PUSHCONST0 
+       2 POP 1
+       4 ATOM0 
+       5 SETGLOBAL T020
+       7 STOP 
+**)
diff --git a/test/testinterp/t021-pushconst1.ml b/test/testinterp/t021-pushconst1.ml
new file mode 100644
index 00000000..075997a8
--- /dev/null
+++ b/test/testinterp/t021-pushconst1.ml
@@ -0,0 +1,10 @@
+let _ = () in 1;;
+
+(**
+       0 CONST0 
+       1 PUSHCONST1 
+       2 POP 1
+       4 ATOM0 
+       5 SETGLOBAL T021-pushconst1
+       7 STOP 
+**)
diff --git a/test/testinterp/t021-pushconst2.ml b/test/testinterp/t021-pushconst2.ml
new file mode 100644
index 00000000..17adb507
--- /dev/null
+++ b/test/testinterp/t021-pushconst2.ml
@@ -0,0 +1,10 @@
+let _ = () in 2;;
+
+(**
+       0 CONST0 
+       1 PUSHCONST2 
+       2 POP 1
+       4 ATOM0 
+       5 SETGLOBAL T021-pushconst2
+       7 STOP 
+**)
diff --git a/test/testinterp/t021-pushconst3.ml b/test/testinterp/t021-pushconst3.ml
new file mode 100644
index 00000000..563c6093
--- /dev/null
+++ b/test/testinterp/t021-pushconst3.ml
@@ -0,0 +1,10 @@
+let _ = () in 3;;
+
+(**
+       0 CONST0 
+       1 PUSHCONST3 
+       2 POP 1
+       4 ATOM0 
+       5 SETGLOBAL T021-pushconst3
+       7 STOP 
+**)
diff --git a/test/testinterp/t022-pushconstint.ml b/test/testinterp/t022-pushconstint.ml
new file mode 100644
index 00000000..1b766a57
--- /dev/null
+++ b/test/testinterp/t022-pushconstint.ml
@@ -0,0 +1,10 @@
+let _ = () in -1;;
+
+(**
+       0 CONST0 
+       1 PUSHCONSTINT -1
+       3 POP 1
+       5 ATOM0 
+       6 SETGLOBAL T022-pushconstint
+       8 STOP 
+**)
diff --git a/test/testinterp/t040-makeblock1.ml b/test/testinterp/t040-makeblock1.ml
new file mode 100644
index 00000000..71516606
--- /dev/null
+++ b/test/testinterp/t040-makeblock1.ml
@@ -0,0 +1,13 @@
+type t = {
+  mutable a : int;
+};;
+
+{ a = 0 };;
+
+(**
+       0 CONST0 
+       1 MAKEBLOCK1 0
+       3 ATOM0 
+       4 SETGLOBAL T040-makeblock1
+       6 STOP 
+**)
diff --git a/test/testinterp/t040-makeblock2.ml b/test/testinterp/t040-makeblock2.ml
new file mode 100644
index 00000000..e7c745b9
--- /dev/null
+++ b/test/testinterp/t040-makeblock2.ml
@@ -0,0 +1,15 @@
+type t = {
+  mutable a : int;
+  mutable b : int;
+};;
+
+{ a = 0; b = 0 };;
+
+(**
+       0 CONST0 
+       1 PUSHCONST0 
+       2 MAKEBLOCK2 0
+       4 ATOM0 
+       5 SETGLOBAL T040-makeblock2
+       7 STOP 
+**)
diff --git a/test/testinterp/t040-makeblock3.ml b/test/testinterp/t040-makeblock3.ml
new file mode 100644
index 00000000..8fb56054
--- /dev/null
+++ b/test/testinterp/t040-makeblock3.ml
@@ -0,0 +1,17 @@
+type t = {
+  mutable a : int;
+  mutable b : int;
+  mutable c : int;
+};;
+
+{ a = 0; b = 0; c = 0 };;
+
+(**
+       0 CONST0 
+       1 PUSHCONST0 
+       2 PUSHCONST0 
+       3 MAKEBLOCK3 0
+       5 ATOM0 
+       6 SETGLOBAL T040-makeblock3
+       8 STOP 
+**)
diff --git a/test/testinterp/t041-makeblock.ml b/test/testinterp/t041-makeblock.ml
new file mode 100644
index 00000000..5ae255d6
--- /dev/null
+++ b/test/testinterp/t041-makeblock.ml
@@ -0,0 +1,19 @@
+type t = {
+  mutable a : int;
+  mutable b : int;
+  mutable c : int;
+  mutable d : int;
+};;
+
+{ a = 0; b = 0; c = 0; d = 0 };;
+
+(**
+       0 CONST0 
+       1 PUSHCONST0 
+       2 PUSHCONST0 
+       3 PUSHCONST0 
+       4 MAKEBLOCK 4, 0
+       7 ATOM0 
+       8 SETGLOBAL T041-makeblock
+      10 STOP 
+**)
diff --git a/test/testinterp/t050-getglobal.ml b/test/testinterp/t050-getglobal.ml
new file mode 100644
index 00000000..f10393cf
--- /dev/null
+++ b/test/testinterp/t050-getglobal.ml
@@ -0,0 +1,8 @@
+[1];;
+
+(**
+       0 GETGLOBAL <0>(1, 0)
+       2 ATOM0 
+       3 SETGLOBAL T050-getglobal
+       5 STOP 
+**)
diff --git a/test/testinterp/t050-pushgetglobal.ml b/test/testinterp/t050-pushgetglobal.ml
new file mode 100644
index 00000000..e1172cc3
--- /dev/null
+++ b/test/testinterp/t050-pushgetglobal.ml
@@ -0,0 +1,10 @@
+let _ = () in 0.01;;
+
+(**
+       0 CONST0 
+       1 PUSHGETGLOBAL 0.01
+       3 POP 1
+       5 ATOM0 
+       6 SETGLOBAL T050-pushgetglobal
+       8 STOP 
+**)
diff --git a/test/testinterp/t051-getglobalfield.ml b/test/testinterp/t051-getglobalfield.ml
new file mode 100644
index 00000000..45d9ccea
--- /dev/null
+++ b/test/testinterp/t051-getglobalfield.ml
@@ -0,0 +1,13 @@
+Lib.x;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBALFIELD Lib, 0
+      12 ATOM0 
+      13 SETGLOBAL T051-getglobalfield
+      15 STOP 
+**)
diff --git a/test/testinterp/t051-pushgetglobalfield.ml b/test/testinterp/t051-pushgetglobalfield.ml
new file mode 100644
index 00000000..2012a257
--- /dev/null
+++ b/test/testinterp/t051-pushgetglobalfield.ml
@@ -0,0 +1,15 @@
+let _ = () in Lib.x;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHGETGLOBALFIELD Lib, 0
+      13 POP 1
+      15 ATOM0 
+      16 SETGLOBAL T051-pushgetglobalfield
+      18 STOP 
+**)
diff --git a/test/testinterp/t060-raise.ml b/test/testinterp/t060-raise.ml
new file mode 100644
index 00000000..1aa48466
--- /dev/null
+++ b/test/testinterp/t060-raise.ml
@@ -0,0 +1,15 @@
+open Lib;;
+raise End_of_file;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL End_of_file
+      11 MAKEBLOCK1 0
+      13 RAISE 
+      14 SETGLOBAL T060-raise
+      16 STOP 
+**)
diff --git a/test/testinterp/t070-branch.ml b/test/testinterp/t070-branch.ml
new file mode 100644
index 00000000..4fc52d42
--- /dev/null
+++ b/test/testinterp/t070-branch.ml
@@ -0,0 +1,20 @@
+open Lib;;
+if true then 0 else raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 BRANCHIFNOT 15
+      12 CONST0 
+      13 BRANCH 20
+      15 GETGLOBAL Not_found
+      17 MAKEBLOCK1 0
+      19 RAISE 
+      20 ATOM0 
+      21 SETGLOBAL T070-branch
+      23 STOP 
+**)
diff --git a/test/testinterp/t070-branchif.ml b/test/testinterp/t070-branchif.ml
new file mode 100644
index 00000000..c256248c
--- /dev/null
+++ b/test/testinterp/t070-branchif.ml
@@ -0,0 +1,20 @@
+open Lib;;
+if not false then 0 else raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 BRANCHIF 15
+      12 CONST0 
+      13 BRANCH 20
+      15 GETGLOBAL Not_found
+      17 MAKEBLOCK1 0
+      19 RAISE 
+      20 ATOM0 
+      21 SETGLOBAL T070-branchif
+      23 STOP 
+**)
diff --git a/test/testinterp/t070-branchifnot.ml b/test/testinterp/t070-branchifnot.ml
new file mode 100644
index 00000000..9e6e4e8b
--- /dev/null
+++ b/test/testinterp/t070-branchifnot.ml
@@ -0,0 +1,18 @@
+open Lib;;
+if false then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 BRANCHIFNOT 17
+      12 GETGLOBAL Not_found
+      14 MAKEBLOCK1 0
+      16 RAISE 
+      17 ATOM0 
+      18 SETGLOBAL T070-branchifnot
+      20 STOP 
+**)
diff --git a/test/testinterp/t071-boolnot.ml b/test/testinterp/t071-boolnot.ml
new file mode 100644
index 00000000..b4a81943
--- /dev/null
+++ b/test/testinterp/t071-boolnot.ml
@@ -0,0 +1,19 @@
+open Lib;;
+if not true then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 BOOLNOT 
+      11 BRANCHIFNOT 18
+      13 GETGLOBAL Not_found
+      15 MAKEBLOCK1 0
+      17 RAISE 
+      18 ATOM0 
+      19 SETGLOBAL T071-boolnot
+      21 STOP 
+**)
diff --git a/test/testinterp/t080-eq.ml b/test/testinterp/t080-eq.ml
new file mode 100644
index 00000000..3ee735f0
--- /dev/null
+++ b/test/testinterp/t080-eq.ml
@@ -0,0 +1,21 @@
+open Lib;;
+if not (0 = 0) then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST0 
+      11 EQ 
+      12 BOOLNOT 
+      13 BRANCHIFNOT 20
+      15 GETGLOBAL Not_found
+      17 MAKEBLOCK1 0
+      19 RAISE 
+      20 ATOM0 
+      21 SETGLOBAL T080-eq
+      23 STOP 
+**)
diff --git a/test/testinterp/t080-geint.ml b/test/testinterp/t080-geint.ml
new file mode 100644
index 00000000..a220b7e9
--- /dev/null
+++ b/test/testinterp/t080-geint.ml
@@ -0,0 +1,21 @@
+open Lib;;
+if not (0 >= 0) then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST0 
+      11 GEINT 
+      12 BOOLNOT 
+      13 BRANCHIFNOT 20
+      15 GETGLOBAL Not_found
+      17 MAKEBLOCK1 0
+      19 RAISE 
+      20 ATOM0 
+      21 SETGLOBAL T080-geint
+      23 STOP 
+**)
diff --git a/test/testinterp/t080-gtint.ml b/test/testinterp/t080-gtint.ml
new file mode 100644
index 00000000..32d57321
--- /dev/null
+++ b/test/testinterp/t080-gtint.ml
@@ -0,0 +1,20 @@
+open Lib;;
+if 0 > 0 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST0 
+      11 GTINT 
+      12 BRANCHIFNOT 19
+      14 GETGLOBAL Not_found
+      16 MAKEBLOCK1 0
+      18 RAISE 
+      19 ATOM0 
+      20 SETGLOBAL T080-gtint
+      22 STOP 
+**)
diff --git a/test/testinterp/t080-leint.ml b/test/testinterp/t080-leint.ml
new file mode 100644
index 00000000..cc983a08
--- /dev/null
+++ b/test/testinterp/t080-leint.ml
@@ -0,0 +1,21 @@
+open Lib;;
+if not (0 <= 0) then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST0 
+      11 LEINT 
+      12 BOOLNOT 
+      13 BRANCHIFNOT 20
+      15 GETGLOBAL Not_found
+      17 MAKEBLOCK1 0
+      19 RAISE 
+      20 ATOM0 
+      21 SETGLOBAL T080-leint
+      23 STOP 
+**)
diff --git a/test/testinterp/t080-ltint.ml b/test/testinterp/t080-ltint.ml
new file mode 100644
index 00000000..ae7d240a
--- /dev/null
+++ b/test/testinterp/t080-ltint.ml
@@ -0,0 +1,20 @@
+open Lib;;
+if 0 < 0 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST0 
+      11 LTINT 
+      12 BRANCHIFNOT 19
+      14 GETGLOBAL Not_found
+      16 MAKEBLOCK1 0
+      18 RAISE 
+      19 ATOM0 
+      20 SETGLOBAL T080-ltint
+      22 STOP 
+**)
diff --git a/test/testinterp/t080-neq.ml b/test/testinterp/t080-neq.ml
new file mode 100644
index 00000000..5066e9cb
--- /dev/null
+++ b/test/testinterp/t080-neq.ml
@@ -0,0 +1,20 @@
+open Lib;;
+if 0 <> 0 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST0 
+      11 NEQ 
+      12 BRANCHIFNOT 19
+      14 GETGLOBAL Not_found
+      16 MAKEBLOCK1 0
+      18 RAISE 
+      19 ATOM0 
+      20 SETGLOBAL T080-neq
+      22 STOP 
+**)
diff --git a/test/testinterp/t090-acc0.ml b/test/testinterp/t090-acc0.ml
new file mode 100644
index 00000000..74acceca
--- /dev/null
+++ b/test/testinterp/t090-acc0.ml
@@ -0,0 +1,25 @@
+open Lib;;
+let x = true in
+();
+if not x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST0 
+      11 ACC0 
+      12 BOOLNOT 
+      13 BRANCHIFNOT 20
+      15 GETGLOBAL Not_found
+      17 MAKEBLOCK1 0
+      19 RAISE 
+      20 POP 1
+      22 ATOM0 
+      23 SETGLOBAL T090-acc0
+      25 STOP 
+**)
diff --git a/test/testinterp/t090-acc1.ml b/test/testinterp/t090-acc1.ml
new file mode 100644
index 00000000..fc9b0254
--- /dev/null
+++ b/test/testinterp/t090-acc1.ml
@@ -0,0 +1,27 @@
+open Lib;;
+let x = true in
+let y = false in
+();
+if not x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST0 
+      11 PUSHCONST0 
+      12 ACC1 
+      13 BOOLNOT 
+      14 BRANCHIFNOT 21
+      16 GETGLOBAL Not_found
+      18 MAKEBLOCK1 0
+      20 RAISE 
+      21 POP 2
+      23 ATOM0 
+      24 SETGLOBAL T090-acc1
+      26 STOP 
+**)
diff --git a/test/testinterp/t090-acc2.ml b/test/testinterp/t090-acc2.ml
new file mode 100644
index 00000000..48659449
--- /dev/null
+++ b/test/testinterp/t090-acc2.ml
@@ -0,0 +1,29 @@
+open Lib;;
+let x = true in
+let y = false in
+let z = false in
+();
+if not x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST0 
+      11 PUSHCONST0 
+      12 PUSHCONST0 
+      13 ACC2 
+      14 BOOLNOT 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 POP 3
+      24 ATOM0 
+      25 SETGLOBAL T090-acc2
+      27 STOP 
+**)
diff --git a/test/testinterp/t090-acc3.ml b/test/testinterp/t090-acc3.ml
new file mode 100644
index 00000000..9622456a
--- /dev/null
+++ b/test/testinterp/t090-acc3.ml
@@ -0,0 +1,31 @@
+open Lib;;
+let x = true in
+let y = false in
+let z = false in
+let a = false in
+();
+if not x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST0 
+      11 PUSHCONST0 
+      12 PUSHCONST0 
+      13 PUSHCONST0 
+      14 ACC3 
+      15 BOOLNOT 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 POP 4
+      25 ATOM0 
+      26 SETGLOBAL T090-acc3
+      28 STOP 
+**)
diff --git a/test/testinterp/t090-acc4.ml b/test/testinterp/t090-acc4.ml
new file mode 100644
index 00000000..992559b7
--- /dev/null
+++ b/test/testinterp/t090-acc4.ml
@@ -0,0 +1,33 @@
+open Lib;;
+let x = true in
+let y = false in
+let z = false in
+let a = false in
+let b = false in
+();
+if not x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST0 
+      11 PUSHCONST0 
+      12 PUSHCONST0 
+      13 PUSHCONST0 
+      14 PUSHCONST0 
+      15 ACC4 
+      16 BOOLNOT 
+      17 BRANCHIFNOT 24
+      19 GETGLOBAL Not_found
+      21 MAKEBLOCK1 0
+      23 RAISE 
+      24 POP 5
+      26 ATOM0 
+      27 SETGLOBAL T090-acc4
+      29 STOP 
+**)
diff --git a/test/testinterp/t090-acc5.ml b/test/testinterp/t090-acc5.ml
new file mode 100644
index 00000000..57f7453b
--- /dev/null
+++ b/test/testinterp/t090-acc5.ml
@@ -0,0 +1,35 @@
+open Lib;;
+let x = true in
+let y = false in
+let z = false in
+let a = false in
+let b = false in
+let c = false in
+();
+if not x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST0 
+      11 PUSHCONST0 
+      12 PUSHCONST0 
+      13 PUSHCONST0 
+      14 PUSHCONST0 
+      15 PUSHCONST0 
+      16 ACC5 
+      17 BOOLNOT 
+      18 BRANCHIFNOT 25
+      20 GETGLOBAL Not_found
+      22 MAKEBLOCK1 0
+      24 RAISE 
+      25 POP 6
+      27 ATOM0 
+      28 SETGLOBAL T090-acc5
+      30 STOP 
+**)
diff --git a/test/testinterp/t090-acc6.ml b/test/testinterp/t090-acc6.ml
new file mode 100644
index 00000000..f9400282
--- /dev/null
+++ b/test/testinterp/t090-acc6.ml
@@ -0,0 +1,37 @@
+open Lib;;
+let x = true in
+let y = false in
+let z = false in
+let a = false in
+let b = false in
+let c = false in
+let d = false in
+();
+if not x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST0 
+      11 PUSHCONST0 
+      12 PUSHCONST0 
+      13 PUSHCONST0 
+      14 PUSHCONST0 
+      15 PUSHCONST0 
+      16 PUSHCONST0 
+      17 ACC6 
+      18 BOOLNOT 
+      19 BRANCHIFNOT 26
+      21 GETGLOBAL Not_found
+      23 MAKEBLOCK1 0
+      25 RAISE 
+      26 POP 7
+      28 ATOM0 
+      29 SETGLOBAL T090-acc6
+      31 STOP 
+**)
diff --git a/test/testinterp/t090-acc7.ml b/test/testinterp/t090-acc7.ml
new file mode 100644
index 00000000..366191bf
--- /dev/null
+++ b/test/testinterp/t090-acc7.ml
@@ -0,0 +1,39 @@
+open Lib;;
+let x = true in
+let y = false in
+let z = false in
+let a = false in
+let b = false in
+let c = false in
+let d = false in
+let e = false in
+();
+if not x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST0 
+      11 PUSHCONST0 
+      12 PUSHCONST0 
+      13 PUSHCONST0 
+      14 PUSHCONST0 
+      15 PUSHCONST0 
+      16 PUSHCONST0 
+      17 PUSHCONST0 
+      18 ACC7 
+      19 BOOLNOT 
+      20 BRANCHIFNOT 27
+      22 GETGLOBAL Not_found
+      24 MAKEBLOCK1 0
+      26 RAISE 
+      27 POP 8
+      29 ATOM0 
+      30 SETGLOBAL T090-acc7
+      32 STOP 
+**)
diff --git a/test/testinterp/t091-acc.ml b/test/testinterp/t091-acc.ml
new file mode 100644
index 00000000..26b003f6
--- /dev/null
+++ b/test/testinterp/t091-acc.ml
@@ -0,0 +1,41 @@
+open Lib;;
+let x = true in
+let y = false in
+let z = false in
+let a = false in
+let b = false in
+let c = false in
+let d = false in
+let e = false in
+let f = false in
+();
+if not x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST0 
+      11 PUSHCONST0 
+      12 PUSHCONST0 
+      13 PUSHCONST0 
+      14 PUSHCONST0 
+      15 PUSHCONST0 
+      16 PUSHCONST0 
+      17 PUSHCONST0 
+      18 PUSHCONST0 
+      19 ACC 8
+      21 BOOLNOT 
+      22 BRANCHIFNOT 29
+      24 GETGLOBAL Not_found
+      26 MAKEBLOCK1 0
+      28 RAISE 
+      29 POP 9
+      31 ATOM0 
+      32 SETGLOBAL T091-acc
+      34 STOP 
+**)
diff --git a/test/testinterp/t092-pushacc.ml b/test/testinterp/t092-pushacc.ml
new file mode 100644
index 00000000..c21561ec
--- /dev/null
+++ b/test/testinterp/t092-pushacc.ml
@@ -0,0 +1,38 @@
+open Lib;;
+let x = false in
+let y = true in
+let z = true in
+let a = true in
+let b = true in
+let c = true in
+let d = true in
+let e = true in
+let f = true in
+if x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST1 
+      11 PUSHCONST1 
+      12 PUSHCONST1 
+      13 PUSHCONST1 
+      14 PUSHCONST1 
+      15 PUSHCONST1 
+      16 PUSHCONST1 
+      17 PUSHCONST1 
+      18 PUSHACC 8
+      20 BRANCHIFNOT 27
+      22 GETGLOBAL Not_found
+      24 MAKEBLOCK1 0
+      26 RAISE 
+      27 POP 9
+      29 ATOM0 
+      30 SETGLOBAL T092-pushacc
+      32 STOP 
+**)
diff --git a/test/testinterp/t092-pushacc0.ml b/test/testinterp/t092-pushacc0.ml
new file mode 100644
index 00000000..ffdc3b04
--- /dev/null
+++ b/test/testinterp/t092-pushacc0.ml
@@ -0,0 +1,22 @@
+open Lib;;
+let x = false in
+if x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHACC0 
+      11 BRANCHIFNOT 18
+      13 GETGLOBAL Not_found
+      15 MAKEBLOCK1 0
+      17 RAISE 
+      18 POP 1
+      20 ATOM0 
+      21 SETGLOBAL T092-pushacc0
+      23 STOP 
+**)
diff --git a/test/testinterp/t092-pushacc1.ml b/test/testinterp/t092-pushacc1.ml
new file mode 100644
index 00000000..b923f4fc
--- /dev/null
+++ b/test/testinterp/t092-pushacc1.ml
@@ -0,0 +1,24 @@
+open Lib;;
+let x = false in
+let y = true in
+if x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST1 
+      11 PUSHACC1 
+      12 BRANCHIFNOT 19
+      14 GETGLOBAL Not_found
+      16 MAKEBLOCK1 0
+      18 RAISE 
+      19 POP 2
+      21 ATOM0 
+      22 SETGLOBAL T092-pushacc1
+      24 STOP 
+**)
diff --git a/test/testinterp/t092-pushacc2.ml b/test/testinterp/t092-pushacc2.ml
new file mode 100644
index 00000000..f6249783
--- /dev/null
+++ b/test/testinterp/t092-pushacc2.ml
@@ -0,0 +1,26 @@
+open Lib;;
+let x = false in
+let y = true in
+let z = true in
+if x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST1 
+      11 PUSHCONST1 
+      12 PUSHACC2 
+      13 BRANCHIFNOT 20
+      15 GETGLOBAL Not_found
+      17 MAKEBLOCK1 0
+      19 RAISE 
+      20 POP 3
+      22 ATOM0 
+      23 SETGLOBAL T092-pushacc2
+      25 STOP 
+**)
diff --git a/test/testinterp/t092-pushacc3.ml b/test/testinterp/t092-pushacc3.ml
new file mode 100644
index 00000000..5984fec7
--- /dev/null
+++ b/test/testinterp/t092-pushacc3.ml
@@ -0,0 +1,28 @@
+open Lib;;
+let x = false in
+let y = true in
+let z = true in
+let a = true in
+if x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST1 
+      11 PUSHCONST1 
+      12 PUSHCONST1 
+      13 PUSHACC3 
+      14 BRANCHIFNOT 21
+      16 GETGLOBAL Not_found
+      18 MAKEBLOCK1 0
+      20 RAISE 
+      21 POP 4
+      23 ATOM0 
+      24 SETGLOBAL T092-pushacc3
+      26 STOP 
+**)
diff --git a/test/testinterp/t092-pushacc4.ml b/test/testinterp/t092-pushacc4.ml
new file mode 100644
index 00000000..ce20e0b9
--- /dev/null
+++ b/test/testinterp/t092-pushacc4.ml
@@ -0,0 +1,30 @@
+open Lib;;
+let x = false in
+let y = true in
+let z = true in
+let a = true in
+let b = true in
+if x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST1 
+      11 PUSHCONST1 
+      12 PUSHCONST1 
+      13 PUSHCONST1 
+      14 PUSHACC4 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 POP 5
+      24 ATOM0 
+      25 SETGLOBAL T092-pushacc4
+      27 STOP 
+**)
diff --git a/test/testinterp/t092-pushacc5.ml b/test/testinterp/t092-pushacc5.ml
new file mode 100644
index 00000000..030f3f04
--- /dev/null
+++ b/test/testinterp/t092-pushacc5.ml
@@ -0,0 +1,32 @@
+open Lib;;
+let x = false in
+let y = true in
+let z = true in
+let a = true in
+let b = true in
+let c = true in
+if x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST1 
+      11 PUSHCONST1 
+      12 PUSHCONST1 
+      13 PUSHCONST1 
+      14 PUSHCONST1 
+      15 PUSHACC5 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 POP 6
+      25 ATOM0 
+      26 SETGLOBAL T092-pushacc5
+      28 STOP 
+**)
diff --git a/test/testinterp/t092-pushacc6.ml b/test/testinterp/t092-pushacc6.ml
new file mode 100644
index 00000000..9c67b808
--- /dev/null
+++ b/test/testinterp/t092-pushacc6.ml
@@ -0,0 +1,34 @@
+open Lib;;
+let x = false in
+let y = true in
+let z = true in
+let a = true in
+let b = true in
+let c = true in
+let d = true in
+if x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST1 
+      11 PUSHCONST1 
+      12 PUSHCONST1 
+      13 PUSHCONST1 
+      14 PUSHCONST1 
+      15 PUSHCONST1 
+      16 PUSHACC6 
+      17 BRANCHIFNOT 24
+      19 GETGLOBAL Not_found
+      21 MAKEBLOCK1 0
+      23 RAISE 
+      24 POP 7
+      26 ATOM0 
+      27 SETGLOBAL T092-pushacc6
+      29 STOP 
+**)
diff --git a/test/testinterp/t092-pushacc7.ml b/test/testinterp/t092-pushacc7.ml
new file mode 100644
index 00000000..09fbbcaf
--- /dev/null
+++ b/test/testinterp/t092-pushacc7.ml
@@ -0,0 +1,36 @@
+open Lib;;
+let x = false in
+let y = true in
+let z = true in
+let a = true in
+let b = true in
+let c = true in
+let d = true in
+let e = true in
+if x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST1 
+      11 PUSHCONST1 
+      12 PUSHCONST1 
+      13 PUSHCONST1 
+      14 PUSHCONST1 
+      15 PUSHCONST1 
+      16 PUSHCONST1 
+      17 PUSHACC7 
+      18 BRANCHIFNOT 25
+      20 GETGLOBAL Not_found
+      22 MAKEBLOCK1 0
+      24 RAISE 
+      25 POP 8
+      27 ATOM0 
+      28 SETGLOBAL T092-pushacc7
+      30 STOP 
+**)
diff --git a/test/testinterp/t093-pushacc.ml b/test/testinterp/t093-pushacc.ml
new file mode 100644
index 00000000..00a969ad
--- /dev/null
+++ b/test/testinterp/t093-pushacc.ml
@@ -0,0 +1,38 @@
+open Lib;;
+let x = false in
+let y = true in
+let z = true in
+let a = true in
+let b = true in
+let c = true in
+let d = true in
+let e = true in
+let f = true in
+if x then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST1 
+      11 PUSHCONST1 
+      12 PUSHCONST1 
+      13 PUSHCONST1 
+      14 PUSHCONST1 
+      15 PUSHCONST1 
+      16 PUSHCONST1 
+      17 PUSHCONST1 
+      18 PUSHACC 8
+      20 BRANCHIFNOT 27
+      22 GETGLOBAL Not_found
+      24 MAKEBLOCK1 0
+      26 RAISE 
+      27 POP 9
+      29 ATOM0 
+      30 SETGLOBAL T093-pushacc
+      32 STOP 
+**)
diff --git a/test/testinterp/t100-pushtrap.ml b/test/testinterp/t100-pushtrap.ml
new file mode 100644
index 00000000..7b02a862
--- /dev/null
+++ b/test/testinterp/t100-pushtrap.ml
@@ -0,0 +1,21 @@
+open Lib;;
+try raise Not_found
+with _ -> ()
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 PUSHTRAP 16
+      11 GETGLOBAL Not_found
+      13 MAKEBLOCK1 0
+      15 RAISE 
+      16 PUSHCONST0 
+      17 POP 1
+      19 ATOM0 
+      20 SETGLOBAL T100-pushtrap
+      22 STOP 
+**)
diff --git a/test/testinterp/t101-poptrap.ml b/test/testinterp/t101-poptrap.ml
new file mode 100644
index 00000000..3a754a06
--- /dev/null
+++ b/test/testinterp/t101-poptrap.ml
@@ -0,0 +1,21 @@
+open Lib;;
+try ()
+with _ -> ()
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 PUSHTRAP 15
+      11 CONST0 
+      12 POPTRAP 
+      13 BRANCH 18
+      15 PUSHCONST0 
+      16 POP 1
+      18 ATOM0 
+      19 SETGLOBAL T101-poptrap
+      21 STOP 
+**)
diff --git a/test/testinterp/t110-addint.ml b/test/testinterp/t110-addint.ml
new file mode 100644
index 00000000..5d683c57
--- /dev/null
+++ b/test/testinterp/t110-addint.ml
@@ -0,0 +1,26 @@
+open Lib;;
+let x = 1 in
+if 1 + x <> 2 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST2 
+      11 PUSHACC1 
+      12 PUSHCONST1 
+      13 ADDINT 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 POP 1
+      24 ATOM0 
+      25 SETGLOBAL T110-addint
+      27 STOP 
+**)
diff --git a/test/testinterp/t110-andint.ml b/test/testinterp/t110-andint.ml
new file mode 100644
index 00000000..016dc3cd
--- /dev/null
+++ b/test/testinterp/t110-andint.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if (3 land 6) <> 2 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST2 
+      10 PUSHCONSTINT 6
+      12 PUSHCONST3 
+      13 ANDINT 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T110-andint
+      25 STOP 
+**)
diff --git a/test/testinterp/t110-asrint-1.ml b/test/testinterp/t110-asrint-1.ml
new file mode 100644
index 00000000..173bdca2
--- /dev/null
+++ b/test/testinterp/t110-asrint-1.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if (-2 asr 1) <> -1 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT -1
+      11 PUSHCONST1 
+      12 PUSHCONSTINT -2
+      14 ASRINT 
+      15 NEQ 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 ATOM0 
+      24 SETGLOBAL T110-asrint-1
+      26 STOP 
+**)
diff --git a/test/testinterp/t110-asrint-2.ml b/test/testinterp/t110-asrint-2.ml
new file mode 100644
index 00000000..386fc64c
--- /dev/null
+++ b/test/testinterp/t110-asrint-2.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if (3 asr 1) <> 1 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST1 
+      11 PUSHCONST3 
+      12 ASRINT 
+      13 NEQ 
+      14 BRANCHIFNOT 21
+      16 GETGLOBAL Not_found
+      18 MAKEBLOCK1 0
+      20 RAISE 
+      21 ATOM0 
+      22 SETGLOBAL T110-asrint-2
+      24 STOP 
+**)
diff --git a/test/testinterp/t110-divint-1.ml b/test/testinterp/t110-divint-1.ml
new file mode 100644
index 00000000..5cde135d
--- /dev/null
+++ b/test/testinterp/t110-divint-1.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if 2 / 2 <> 1 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST2 
+      11 PUSHCONST2 
+      12 DIVINT 
+      13 NEQ 
+      14 BRANCHIFNOT 21
+      16 GETGLOBAL Not_found
+      18 MAKEBLOCK1 0
+      20 RAISE 
+      21 ATOM0 
+      22 SETGLOBAL T110-divint-1
+      24 STOP 
+**)
diff --git a/test/testinterp/t110-divint-2.ml b/test/testinterp/t110-divint-2.ml
new file mode 100644
index 00000000..34f5b00c
--- /dev/null
+++ b/test/testinterp/t110-divint-2.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if 3 / 2 <> 1 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST2 
+      11 PUSHCONST3 
+      12 DIVINT 
+      13 NEQ 
+      14 BRANCHIFNOT 21
+      16 GETGLOBAL Not_found
+      18 MAKEBLOCK1 0
+      20 RAISE 
+      21 ATOM0 
+      22 SETGLOBAL T110-divint-2
+      24 STOP 
+**)
diff --git a/test/testinterp/t110-divint-3.ml b/test/testinterp/t110-divint-3.ml
new file mode 100644
index 00000000..cbb2bff1
--- /dev/null
+++ b/test/testinterp/t110-divint-3.ml
@@ -0,0 +1,33 @@
+open Lib;;
+try
+  ignore (3 / 0);
+  raise Not_found;
+with Division_by_zero -> ()
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 PUSHTRAP 19
+      11 CONST0 
+      12 PUSHCONST3 
+      13 DIVINT 
+      14 GETGLOBAL Not_found
+      16 MAKEBLOCK1 0
+      18 RAISE 
+      19 PUSHGETGLOBAL Division_by_zero
+      21 PUSHACC1 
+      22 GETFIELD0 
+      23 EQ 
+      24 BRANCHIFNOT 29
+      26 CONST0 
+      27 BRANCH 31
+      29 ACC0 
+      30 RAISE 
+      31 POP 1
+      33 ATOM0 
+      34 SETGLOBAL T110-divint-3
+      36 STOP 
+**)
diff --git a/test/testinterp/t110-lslint.ml b/test/testinterp/t110-lslint.ml
new file mode 100644
index 00000000..9dd197b4
--- /dev/null
+++ b/test/testinterp/t110-lslint.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if (3 lsl 2) <> 12 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 12
+      11 PUSHCONST2 
+      12 PUSHCONST3 
+      13 LSLINT 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T110-lslint
+      25 STOP 
+**)
diff --git a/test/testinterp/t110-lsrint.ml b/test/testinterp/t110-lsrint.ml
new file mode 100644
index 00000000..9777815c
--- /dev/null
+++ b/test/testinterp/t110-lsrint.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if (14 lsr 2) <> 3 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST3 
+      10 PUSHCONST2 
+      11 PUSHCONSTINT 14
+      13 LSRINT 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T110-lsrint
+      25 STOP 
+**)
diff --git a/test/testinterp/t110-modint-1.ml b/test/testinterp/t110-modint-1.ml
new file mode 100644
index 00000000..2a690c08
--- /dev/null
+++ b/test/testinterp/t110-modint-1.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if 20 mod 3 <> 2 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST2 
+      10 PUSHCONST3 
+      11 PUSHCONSTINT 20
+      13 MODINT 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T110-modint-1
+      25 STOP 
+**)
diff --git a/test/testinterp/t110-modint-2.ml b/test/testinterp/t110-modint-2.ml
new file mode 100644
index 00000000..0bc3be0c
--- /dev/null
+++ b/test/testinterp/t110-modint-2.ml
@@ -0,0 +1,34 @@
+open Lib;;
+try
+  ignore (2 mod 0);
+  raise Not_found;
+with Division_by_zero -> ()
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 PUSHTRAP 19
+      11 CONST0 
+      12 PUSHCONST2 
+      13 MODINT 
+      14 GETGLOBAL Not_found
+      16 MAKEBLOCK1 0
+      18 RAISE 
+      19 PUSHGETGLOBAL Division_by_zero
+      21 PUSHACC1 
+      22 GETFIELD0 
+      23 EQ 
+      24 BRANCHIFNOT 29
+      26 CONST0 
+      27 BRANCH 31
+      29 ACC0 
+      30 RAISE 
+      31 POP 1
+      33 ATOM0 
+      34 SETGLOBAL T110-modint-2
+      36 STOP 
+**)
diff --git a/test/testinterp/t110-mulint.ml b/test/testinterp/t110-mulint.ml
new file mode 100644
index 00000000..97c1cf14
--- /dev/null
+++ b/test/testinterp/t110-mulint.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if 2 * 2 <> 4 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 4
+      11 PUSHCONST2 
+      12 PUSHCONST2 
+      13 MULINT 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T110-mulint
+      25 STOP 
+**)
diff --git a/test/testinterp/t110-negint.ml b/test/testinterp/t110-negint.ml
new file mode 100644
index 00000000..069a34b2
--- /dev/null
+++ b/test/testinterp/t110-negint.ml
@@ -0,0 +1,25 @@
+open Lib;;
+let x = 1 in
+if -x <> -1 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONSTINT -1
+      12 PUSHACC1 
+      13 NEGINT 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 POP 1
+      24 ATOM0 
+      25 SETGLOBAL T110-negint
+      27 STOP 
+**)
diff --git a/test/testinterp/t110-offsetint.ml b/test/testinterp/t110-offsetint.ml
new file mode 100644
index 00000000..925159e3
--- /dev/null
+++ b/test/testinterp/t110-offsetint.ml
@@ -0,0 +1,21 @@
+open Lib;;
+if 2 + 2 <> 4 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 4
+      11 PUSHCONST2 
+      12 OFFSETINT 2
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T110-offsetint
+      25 STOP 
+**)
diff --git a/test/testinterp/t110-orint.ml b/test/testinterp/t110-orint.ml
new file mode 100644
index 00000000..56b63d80
--- /dev/null
+++ b/test/testinterp/t110-orint.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if (3 lor 6) <> 7 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 7
+      11 PUSHCONSTINT 6
+      13 PUSHCONST3 
+      14 ORINT 
+      15 NEQ 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 ATOM0 
+      24 SETGLOBAL T110-orint
+      26 STOP 
+**)
diff --git a/test/testinterp/t110-subint.ml b/test/testinterp/t110-subint.ml
new file mode 100644
index 00000000..f626cd0d
--- /dev/null
+++ b/test/testinterp/t110-subint.ml
@@ -0,0 +1,26 @@
+open Lib;;
+let x = 1 in
+if 1 - x <> 0 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST0 
+      11 PUSHACC1 
+      12 PUSHCONST1 
+      13 SUBINT 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 POP 1
+      24 ATOM0 
+      25 SETGLOBAL T110-subint
+      27 STOP 
+**)
diff --git a/test/testinterp/t110-xorint.ml b/test/testinterp/t110-xorint.ml
new file mode 100644
index 00000000..dfb278b7
--- /dev/null
+++ b/test/testinterp/t110-xorint.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if (3 lxor 6) <> 5 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 5
+      11 PUSHCONSTINT 6
+      13 PUSHCONST3 
+      14 XORINT 
+      15 NEQ 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 ATOM0 
+      24 SETGLOBAL T110-xorint
+      26 STOP 
+**)
diff --git a/test/testinterp/t120-getstringchar.ml b/test/testinterp/t120-getstringchar.ml
new file mode 100644
index 00000000..aaff2022
--- /dev/null
+++ b/test/testinterp/t120-getstringchar.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if "foo".[2] <> 'o' then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 111
+      11 PUSHCONST2 
+      12 PUSHGETGLOBAL "foo"
+      14 GETSTRINGCHAR 
+      15 NEQ 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 ATOM0 
+      24 SETGLOBAL T120-getstringchar
+      26 STOP 
+**)
diff --git a/test/testinterp/t121-setstringchar.ml b/test/testinterp/t121-setstringchar.ml
new file mode 100644
index 00000000..882d6e08
--- /dev/null
+++ b/test/testinterp/t121-setstringchar.ml
@@ -0,0 +1,31 @@
+open Lib;;
+let x = "foo" in
+x.[2] <- 'x';
+if x.[2] <> 'x' then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL "foo"
+      11 PUSHCONSTINT 120
+      13 PUSHCONST2 
+      14 PUSHACC2 
+      15 SETSTRINGCHAR 
+      16 CONSTINT 120
+      18 PUSHCONST2 
+      19 PUSHACC2 
+      20 GETSTRINGCHAR 
+      21 NEQ 
+      22 BRANCHIFNOT 29
+      24 GETGLOBAL Not_found
+      26 MAKEBLOCK1 0
+      28 RAISE 
+      29 POP 1
+      31 ATOM0 
+      32 SETGLOBAL T121-setstringchar
+      34 STOP 
+**)
diff --git a/test/testinterp/t130-getvectitem.ml b/test/testinterp/t130-getvectitem.ml
new file mode 100644
index 00000000..d2903795
--- /dev/null
+++ b/test/testinterp/t130-getvectitem.ml
@@ -0,0 +1,24 @@
+open Lib;;
+if [| 1; 2 |].(1) <> 2 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST2 
+      10 PUSHCONST1 
+      11 PUSHCONST2 
+      12 PUSHCONST1 
+      13 MAKEBLOCK2 0
+      15 GETVECTITEM 
+      16 NEQ 
+      17 BRANCHIFNOT 24
+      19 GETGLOBAL Not_found
+      21 MAKEBLOCK1 0
+      23 RAISE 
+      24 ATOM0 
+      25 SETGLOBAL T130-getvectitem
+      27 STOP 
+**)
diff --git a/test/testinterp/t130-vectlength.ml b/test/testinterp/t130-vectlength.ml
new file mode 100644
index 00000000..ce0da0e4
--- /dev/null
+++ b/test/testinterp/t130-vectlength.ml
@@ -0,0 +1,23 @@
+open Lib;;
+if Array.length [| 1; 2 |] <> 2 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST2 
+      10 PUSHCONST2 
+      11 PUSHCONST1 
+      12 MAKEBLOCK2 0
+      14 VECTLENGTH 
+      15 NEQ 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 ATOM0 
+      24 SETGLOBAL T130-vectlength
+      26 STOP 
+**)
diff --git a/test/testinterp/t131-setvectitem.ml b/test/testinterp/t131-setvectitem.ml
new file mode 100644
index 00000000..f544a3e0
--- /dev/null
+++ b/test/testinterp/t131-setvectitem.ml
@@ -0,0 +1,33 @@
+open Lib;;
+let x = [| 1; 2 |] in
+x.(0) <- 3;
+if x.(0) <> 3 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST2 
+      10 PUSHCONST1 
+      11 MAKEBLOCK2 0
+      13 PUSHCONST3 
+      14 PUSHCONST0 
+      15 PUSHACC2 
+      16 SETVECTITEM 
+      17 CONST3 
+      18 PUSHCONST0 
+      19 PUSHACC2 
+      20 GETVECTITEM 
+      21 NEQ 
+      22 BRANCHIFNOT 29
+      24 GETGLOBAL Not_found
+      26 MAKEBLOCK1 0
+      28 RAISE 
+      29 POP 1
+      31 ATOM0 
+      32 SETGLOBAL T131-setvectitem
+      34 STOP 
+**)
diff --git a/test/testinterp/t140-switch-1.ml b/test/testinterp/t140-switch-1.ml
new file mode 100644
index 00000000..b2d73521
--- /dev/null
+++ b/test/testinterp/t140-switch-1.ml
@@ -0,0 +1,32 @@
+open Lib;;
+match 0 with
+| 0 -> ()
+| 1 -> raise Not_found
+| _ -> raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHACC0 
+      11 SWITCH 
+        int 0 -> 17
+        int 1 -> 20
+      15 BRANCH 25
+      17 CONST0 
+      18 BRANCH 30
+      20 GETGLOBAL Not_found
+      22 MAKEBLOCK1 0
+      24 RAISE 
+      25 GETGLOBAL Not_found
+      27 MAKEBLOCK1 0
+      29 RAISE 
+      30 POP 1
+      32 ATOM0 
+      33 SETGLOBAL T140-switch-1
+      35 STOP 
+**)
diff --git a/test/testinterp/t140-switch-2.ml b/test/testinterp/t140-switch-2.ml
new file mode 100644
index 00000000..9004fa66
--- /dev/null
+++ b/test/testinterp/t140-switch-2.ml
@@ -0,0 +1,32 @@
+open Lib;;
+match 1 with
+| 0 -> raise Not_found
+| 1 -> ()
+| _ -> raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHACC0 
+      11 SWITCH 
+        int 0 -> 17
+        int 1 -> 22
+      15 BRANCH 25
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 CONST0 
+      23 BRANCH 30
+      25 GETGLOBAL Not_found
+      27 MAKEBLOCK1 0
+      29 RAISE 
+      30 POP 1
+      32 ATOM0 
+      33 SETGLOBAL T140-switch-2
+      35 STOP 
+**)
diff --git a/test/testinterp/t140-switch-3.ml b/test/testinterp/t140-switch-3.ml
new file mode 100644
index 00000000..b0c4bc8f
--- /dev/null
+++ b/test/testinterp/t140-switch-3.ml
@@ -0,0 +1,31 @@
+open Lib;;
+match 2 with
+| 0 -> raise Not_found
+| 1 -> raise Not_found
+| _ -> ()
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST2 
+      10 PUSHACC0 
+      11 SWITCH 
+        int 0 -> 17
+        int 1 -> 22
+      15 BRANCH 27
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 GETGLOBAL Not_found
+      24 MAKEBLOCK1 0
+      26 RAISE 
+      27 CONST0 
+      28 POP 1
+      30 ATOM0 
+      31 SETGLOBAL T140-switch-3
+      33 STOP 
+**)
diff --git a/test/testinterp/t140-switch-4.ml b/test/testinterp/t140-switch-4.ml
new file mode 100644
index 00000000..1826b09e
--- /dev/null
+++ b/test/testinterp/t140-switch-4.ml
@@ -0,0 +1,31 @@
+open Lib;;
+match -1 with
+| 0 -> raise Not_found
+| 1 -> raise Not_found
+| _ -> ()
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT -1
+      11 PUSHACC0 
+      12 SWITCH 
+        int 0 -> 18
+        int 1 -> 23
+      16 BRANCH 28
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 GETGLOBAL Not_found
+      25 MAKEBLOCK1 0
+      27 RAISE 
+      28 CONST0 
+      29 POP 1
+      31 ATOM0 
+      32 SETGLOBAL T140-switch-4
+      34 STOP 
+**)
diff --git a/test/testinterp/t141-switch-5.ml b/test/testinterp/t141-switch-5.ml
new file mode 100644
index 00000000..ca44849e
--- /dev/null
+++ b/test/testinterp/t141-switch-5.ml
@@ -0,0 +1,38 @@
+open Lib;;
+type t =
+ | A of int
+ | B of int
+ | C of int
+;;
+
+match A 0 with
+| A _ -> ()
+| B _ -> raise Not_found
+| _ -> raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL <0>(0)
+      11 PUSHACC0 
+      12 SWITCH 
+        tag 0 -> 17
+        tag 1 -> 20
+        tag 2 -> 25
+      17 CONST0 
+      18 BRANCH 30
+      20 GETGLOBAL Not_found
+      22 MAKEBLOCK1 0
+      24 RAISE 
+      25 GETGLOBAL Not_found
+      27 MAKEBLOCK1 0
+      29 RAISE 
+      30 POP 1
+      32 ATOM0 
+      33 SETGLOBAL T141-switch-5
+      35 STOP 
+**)
diff --git a/test/testinterp/t141-switch-6.ml b/test/testinterp/t141-switch-6.ml
new file mode 100644
index 00000000..c48e80b5
--- /dev/null
+++ b/test/testinterp/t141-switch-6.ml
@@ -0,0 +1,38 @@
+open Lib;;
+type t =
+ | A of int
+ | B of int
+ | C of int
+;;
+
+match B 0 with
+| A _ -> raise Not_found
+| B _ -> ()
+| _ -> raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL <1>(0)
+      11 PUSHACC0 
+      12 SWITCH 
+        tag 0 -> 17
+        tag 1 -> 22
+        tag 2 -> 25
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 CONST0 
+      23 BRANCH 30
+      25 GETGLOBAL Not_found
+      27 MAKEBLOCK1 0
+      29 RAISE 
+      30 POP 1
+      32 ATOM0 
+      33 SETGLOBAL T141-switch-6
+      35 STOP 
+**)
diff --git a/test/testinterp/t141-switch-7.ml b/test/testinterp/t141-switch-7.ml
new file mode 100644
index 00000000..00f4873c
--- /dev/null
+++ b/test/testinterp/t141-switch-7.ml
@@ -0,0 +1,37 @@
+open Lib;;
+type t =
+ | A of int
+ | B of int
+ | C of int
+;;
+
+match C 0 with
+| A _ -> raise Not_found
+| B _ -> raise Not_found
+| _ -> ()
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL <2>(0)
+      11 PUSHACC0 
+      12 SWITCH 
+        tag 0 -> 17
+        tag 1 -> 22
+        tag 2 -> 27
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 GETGLOBAL Not_found
+      24 MAKEBLOCK1 0
+      26 RAISE 
+      27 CONST0 
+      28 POP 1
+      30 ATOM0 
+      31 SETGLOBAL T141-switch-7
+      33 STOP 
+**)
diff --git a/test/testinterp/t142-switch-8.ml b/test/testinterp/t142-switch-8.ml
new file mode 100644
index 00000000..51459130
--- /dev/null
+++ b/test/testinterp/t142-switch-8.ml
@@ -0,0 +1,34 @@
+open Lib;;
+type t =
+ | A
+ | B of int
+ | C of int
+;;
+
+match A with
+| A -> ()
+| _ -> raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHACC0 
+      11 SWITCH 
+        int 0 -> 16
+        tag 0 -> 19
+        tag 1 -> 19
+      16 CONST0 
+      17 BRANCH 24
+      19 GETGLOBAL Not_found
+      21 MAKEBLOCK1 0
+      23 RAISE 
+      24 POP 1
+      26 ATOM0 
+      27 SETGLOBAL T142-switch-8
+      29 STOP 
+**)
diff --git a/test/testinterp/t142-switch-9.ml b/test/testinterp/t142-switch-9.ml
new file mode 100644
index 00000000..a0e43d32
--- /dev/null
+++ b/test/testinterp/t142-switch-9.ml
@@ -0,0 +1,34 @@
+open Lib;;
+type t =
+ | A
+ | B of int
+ | C of int
+;;
+
+match B 0 with
+| B _ -> ()
+| _ -> raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL <0>(0)
+      11 PUSHACC0 
+      12 SWITCH 
+        int 0 -> 20
+        tag 0 -> 17
+        tag 1 -> 20
+      17 CONST0 
+      18 BRANCH 25
+      20 GETGLOBAL Not_found
+      22 MAKEBLOCK1 0
+      24 RAISE 
+      25 POP 1
+      27 ATOM0 
+      28 SETGLOBAL T142-switch-9
+      30 STOP 
+**)
diff --git a/test/testinterp/t142-switch-A.ml b/test/testinterp/t142-switch-A.ml
new file mode 100644
index 00000000..4f66aec5
--- /dev/null
+++ b/test/testinterp/t142-switch-A.ml
@@ -0,0 +1,34 @@
+open Lib;;
+type t =
+ | A
+ | B of int
+ | C of int
+;;
+
+match C 0 with
+| C _ -> ()
+| _ -> raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL <1>(0)
+      11 PUSHACC0 
+      12 SWITCH 
+        int 0 -> 20
+        tag 0 -> 20
+        tag 1 -> 17
+      17 CONST0 
+      18 BRANCH 25
+      20 GETGLOBAL Not_found
+      22 MAKEBLOCK1 0
+      24 RAISE 
+      25 POP 1
+      27 ATOM0 
+      28 SETGLOBAL T142-switch-A
+      30 STOP 
+**)
diff --git a/test/testinterp/t150-push-1.ml b/test/testinterp/t150-push-1.ml
new file mode 100644
index 00000000..92649277
--- /dev/null
+++ b/test/testinterp/t150-push-1.ml
@@ -0,0 +1,24 @@
+open Lib;;
+let _ = 0 in
+try 0 with _ -> 0
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSH 
+      11 PUSHTRAP 17
+      13 CONST0 
+      14 POPTRAP 
+      15 BRANCH 20
+      17 PUSHCONST0 
+      18 POP 1
+      20 POP 1
+      22 ATOM0 
+      23 SETGLOBAL T150-push-1
+      25 STOP 
+**)
diff --git a/test/testinterp/t150-push-2.ml b/test/testinterp/t150-push-2.ml
new file mode 100644
index 00000000..d6f51072
--- /dev/null
+++ b/test/testinterp/t150-push-2.ml
@@ -0,0 +1,39 @@
+open Lib;;
+let x = 1 in
+try if x <> 1 then raise Not_found
+with End_of_file -> ()
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSH 
+      11 PUSHTRAP 26
+      13 CONST1 
+      14 PUSHACC5 
+      15 NEQ 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 POPTRAP 
+      24 BRANCH 40
+      26 PUSHGETGLOBAL End_of_file
+      28 PUSHACC1 
+      29 GETFIELD0 
+      30 EQ 
+      31 BRANCHIFNOT 36
+      33 CONST0 
+      34 BRANCH 38
+      36 ACC0 
+      37 RAISE 
+      38 POP 1
+      40 POP 1
+      42 ATOM0 
+      43 SETGLOBAL T150-push-2
+      45 STOP 
+**)
diff --git a/test/testinterp/t160-closure.ml b/test/testinterp/t160-closure.ml
new file mode 100644
index 00000000..5eb61286
--- /dev/null
+++ b/test/testinterp/t160-closure.ml
@@ -0,0 +1,19 @@
+open Lib;;
+let f () = ();;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 14
+      11 CONST0 
+      12 RETURN 1
+      14 CLOSURE 0, 11
+      17 PUSHACC0 
+      18 MAKEBLOCK1 0
+      20 POP 1
+      22 SETGLOBAL T160-closure
+      24 STOP 
+**)
diff --git a/test/testinterp/t161-apply1.ml b/test/testinterp/t161-apply1.ml
new file mode 100644
index 00000000..5138c5f5
--- /dev/null
+++ b/test/testinterp/t161-apply1.ml
@@ -0,0 +1,42 @@
+open Lib;;
+let f _ = raise End_of_file in
+try
+  f 0;
+  raise Not_found;
+with End_of_file -> 0
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 16
+      11 GETGLOBAL End_of_file
+      13 MAKEBLOCK1 0
+      15 RAISE 
+      16 CLOSURE 0, 11
+      19 PUSH 
+      20 PUSHTRAP 30
+      22 CONST0 
+      23 PUSHACC5 
+      24 APPLY1 
+      25 GETGLOBAL Not_found
+      27 MAKEBLOCK1 0
+      29 RAISE 
+      30 PUSHGETGLOBAL End_of_file
+      32 PUSHACC1 
+      33 GETFIELD0 
+      34 EQ 
+      35 BRANCHIFNOT 40
+      37 CONST0 
+      38 BRANCH 42
+      40 ACC0 
+      41 RAISE 
+      42 POP 1
+      44 POP 1
+      46 ATOM0 
+      47 SETGLOBAL T161-apply1
+      49 STOP 
+**)
diff --git a/test/testinterp/t162-return.ml b/test/testinterp/t162-return.ml
new file mode 100644
index 00000000..1059c9fe
--- /dev/null
+++ b/test/testinterp/t162-return.ml
@@ -0,0 +1,21 @@
+open Lib;;
+let f _ = 0 in f 0;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 14
+      11 CONST0 
+      12 RETURN 1
+      14 CLOSURE 0, 11
+      17 PUSHCONST0 
+      18 PUSHACC1 
+      19 APPLY1 
+      20 POP 1
+      22 ATOM0 
+      23 SETGLOBAL T162-return
+      25 STOP 
+**)
diff --git a/test/testinterp/t163.ml b/test/testinterp/t163.ml
new file mode 100644
index 00000000..9ec7790c
--- /dev/null
+++ b/test/testinterp/t163.ml
@@ -0,0 +1,23 @@
+open Lib;;
+let f _ _ = 0 in f 0;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 17
+      11 RESTART 
+      12 GRAB 1
+      14 CONST0 
+      15 RETURN 2
+      17 CLOSURE 0, 12
+      20 PUSHCONST0 
+      21 PUSHACC1 
+      22 APPLY1 
+      23 POP 1
+      25 ATOM0 
+      26 SETGLOBAL T163
+      28 STOP 
+**)
diff --git a/test/testinterp/t164-apply2.ml b/test/testinterp/t164-apply2.ml
new file mode 100644
index 00000000..7fbe7d99
--- /dev/null
+++ b/test/testinterp/t164-apply2.ml
@@ -0,0 +1,24 @@
+open Lib;;
+let f _ _ = 0 in f 0 0;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 17
+      11 RESTART 
+      12 GRAB 1
+      14 CONST0 
+      15 RETURN 2
+      17 CLOSURE 0, 12
+      20 PUSHCONST0 
+      21 PUSHCONST0 
+      22 PUSHACC2 
+      23 APPLY2 
+      24 POP 1
+      26 ATOM0 
+      27 SETGLOBAL T164-apply2
+      29 STOP 
+**)
diff --git a/test/testinterp/t164-apply3.ml b/test/testinterp/t164-apply3.ml
new file mode 100644
index 00000000..e7ebc3a4
--- /dev/null
+++ b/test/testinterp/t164-apply3.ml
@@ -0,0 +1,25 @@
+open Lib;;
+let f _ _ _ = 0 in f 0 0 0;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 17
+      11 RESTART 
+      12 GRAB 2
+      14 CONST0 
+      15 RETURN 3
+      17 CLOSURE 0, 12
+      20 PUSHCONST0 
+      21 PUSHCONST0 
+      22 PUSHCONST0 
+      23 PUSHACC3 
+      24 APPLY3 
+      25 POP 1
+      27 ATOM0 
+      28 SETGLOBAL T164-apply3
+      30 STOP 
+**)
diff --git a/test/testinterp/t165-apply.ml b/test/testinterp/t165-apply.ml
new file mode 100644
index 00000000..9d668550
--- /dev/null
+++ b/test/testinterp/t165-apply.ml
@@ -0,0 +1,28 @@
+open Lib;;
+let f _ _ _ _ = 0 in f 0 0 0 0;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 17
+      11 RESTART 
+      12 GRAB 3
+      14 CONST0 
+      15 RETURN 4
+      17 CLOSURE 0, 12
+      20 PUSH 
+      21 PUSH_RETADDR 30
+      23 CONST0 
+      24 PUSHCONST0 
+      25 PUSHCONST0 
+      26 PUSHCONST0 
+      27 PUSHACC7 
+      28 APPLY 4
+      30 POP 1
+      32 ATOM0 
+      33 SETGLOBAL T165-apply
+      35 STOP 
+**)
diff --git a/test/testinterp/t170-envacc2.ml b/test/testinterp/t170-envacc2.ml
new file mode 100644
index 00000000..3a373667
--- /dev/null
+++ b/test/testinterp/t170-envacc2.ml
@@ -0,0 +1,37 @@
+open Lib;;
+let x = 5 in
+let y = 2 in
+let f _ = ignore x; y in
+if f 0 <> 2 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 16
+      11 ENVACC1 
+      12 CONST0 
+      13 ENVACC2 
+      14 RETURN 1
+      16 CONSTINT 5
+      18 PUSHCONST2 
+      19 PUSHACC0 
+      20 PUSHACC2 
+      21 CLOSURE 2, 11
+      24 PUSHCONST2 
+      25 PUSHCONST0 
+      26 PUSHACC2 
+      27 APPLY1 
+      28 NEQ 
+      29 BRANCHIFNOT 36
+      31 GETGLOBAL Not_found
+      33 MAKEBLOCK1 0
+      35 RAISE 
+      36 POP 3
+      38 ATOM0 
+      39 SETGLOBAL T170-envacc2
+      41 STOP 
+**)
diff --git a/test/testinterp/t170-envacc3.ml b/test/testinterp/t170-envacc3.ml
new file mode 100644
index 00000000..9a2b8b5a
--- /dev/null
+++ b/test/testinterp/t170-envacc3.ml
@@ -0,0 +1,42 @@
+open Lib;;
+let x = 5 in
+let y = 2 in
+let z = 1 in
+let f _ = ignore x; ignore y; z in
+if f 0 <> 1 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 18
+      11 ENVACC1 
+      12 CONST0 
+      13 ENVACC2 
+      14 CONST0 
+      15 ENVACC3 
+      16 RETURN 1
+      18 CONSTINT 5
+      20 PUSHCONST2 
+      21 PUSHCONST1 
+      22 PUSHACC0 
+      23 PUSHACC2 
+      24 PUSHACC4 
+      25 CLOSURE 3, 11
+      28 PUSHCONST1 
+      29 PUSHCONST0 
+      30 PUSHACC2 
+      31 APPLY1 
+      32 NEQ 
+      33 BRANCHIFNOT 40
+      35 GETGLOBAL Not_found
+      37 MAKEBLOCK1 0
+      39 RAISE 
+      40 POP 4
+      42 ATOM0 
+      43 SETGLOBAL T170-envacc3
+      45 STOP 
+**)
diff --git a/test/testinterp/t170-envacc4.ml b/test/testinterp/t170-envacc4.ml
new file mode 100644
index 00000000..215e3220
--- /dev/null
+++ b/test/testinterp/t170-envacc4.ml
@@ -0,0 +1,47 @@
+open Lib;;
+let x = 5 in
+let y = 2 in
+let z = 1 in
+let a = 4 in
+let f _ = ignore x; ignore y; ignore z; a in
+if f 0 <> 4 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 20
+      11 ENVACC1 
+      12 CONST0 
+      13 ENVACC2 
+      14 CONST0 
+      15 ENVACC3 
+      16 CONST0 
+      17 ENVACC4 
+      18 RETURN 1
+      20 CONSTINT 5
+      22 PUSHCONST2 
+      23 PUSHCONST1 
+      24 PUSHCONSTINT 4
+      26 PUSHACC0 
+      27 PUSHACC2 
+      28 PUSHACC4 
+      29 PUSHACC6 
+      30 CLOSURE 4, 11
+      33 PUSHCONSTINT 4
+      35 PUSHCONST0 
+      36 PUSHACC2 
+      37 APPLY1 
+      38 NEQ 
+      39 BRANCHIFNOT 46
+      41 GETGLOBAL Not_found
+      43 MAKEBLOCK1 0
+      45 RAISE 
+      46 POP 5
+      48 ATOM0 
+      49 SETGLOBAL T170-envacc4
+      51 STOP 
+**)
diff --git a/test/testinterp/t171-envacc.ml b/test/testinterp/t171-envacc.ml
new file mode 100644
index 00000000..4c4a3dfa
--- /dev/null
+++ b/test/testinterp/t171-envacc.ml
@@ -0,0 +1,52 @@
+open Lib;;
+let x = 5 in
+let y = 2 in
+let z = 1 in
+let a = 4 in
+let b = 3 in
+let f _ = ignore x; ignore y; ignore z; ignore a; b in
+if f 0 <> 3 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 23
+      11 ENVACC1 
+      12 CONST0 
+      13 ENVACC2 
+      14 CONST0 
+      15 ENVACC3 
+      16 CONST0 
+      17 ENVACC4 
+      18 CONST0 
+      19 ENVACC 5
+      21 RETURN 1
+      23 CONSTINT 5
+      25 PUSHCONST2 
+      26 PUSHCONST1 
+      27 PUSHCONSTINT 4
+      29 PUSHCONST3 
+      30 PUSHACC0 
+      31 PUSHACC2 
+      32 PUSHACC4 
+      33 PUSHACC6 
+      34 PUSHACC 8
+      36 CLOSURE 5, 11
+      39 PUSHCONST3 
+      40 PUSHCONST0 
+      41 PUSHACC2 
+      42 APPLY1 
+      43 NEQ 
+      44 BRANCHIFNOT 51
+      46 GETGLOBAL Not_found
+      48 MAKEBLOCK1 0
+      50 RAISE 
+      51 POP 6
+      53 ATOM0 
+      54 SETGLOBAL T171-envacc
+      56 STOP 
+**)
diff --git a/test/testinterp/t172-pushenvacc1.ml b/test/testinterp/t172-pushenvacc1.ml
new file mode 100644
index 00000000..06c4011a
--- /dev/null
+++ b/test/testinterp/t172-pushenvacc1.ml
@@ -0,0 +1,34 @@
+open Lib;;
+let x = 5 in
+let f _ = x + x in
+if f 0 <> 10 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 16
+      11 ENVACC1 
+      12 PUSHENVACC1 
+      13 ADDINT 
+      14 RETURN 1
+      16 CONSTINT 5
+      18 PUSHACC0 
+      19 CLOSURE 1, 11
+      22 PUSHCONSTINT 10
+      24 PUSHCONST0 
+      25 PUSHACC2 
+      26 APPLY1 
+      27 NEQ 
+      28 BRANCHIFNOT 35
+      30 GETGLOBAL Not_found
+      32 MAKEBLOCK1 0
+      34 RAISE 
+      35 POP 2
+      37 ATOM0 
+      38 SETGLOBAL T172-pushenvacc1
+      40 STOP 
+**)
diff --git a/test/testinterp/t172-pushenvacc2.ml b/test/testinterp/t172-pushenvacc2.ml
new file mode 100644
index 00000000..c25e40a7
--- /dev/null
+++ b/test/testinterp/t172-pushenvacc2.ml
@@ -0,0 +1,37 @@
+open Lib;;
+let x = 5 in
+let y = 4 in
+let f _ = y + x in
+if f 0 <> 9 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 16
+      11 ENVACC1 
+      12 PUSHENVACC2 
+      13 ADDINT 
+      14 RETURN 1
+      16 CONSTINT 5
+      18 PUSHCONSTINT 4
+      20 PUSHACC0 
+      21 PUSHACC2 
+      22 CLOSURE 2, 11
+      25 PUSHCONSTINT 9
+      27 PUSHCONST0 
+      28 PUSHACC2 
+      29 APPLY1 
+      30 NEQ 
+      31 BRANCHIFNOT 38
+      33 GETGLOBAL Not_found
+      35 MAKEBLOCK1 0
+      37 RAISE 
+      38 POP 3
+      40 ATOM0 
+      41 SETGLOBAL T172-pushenvacc2
+      43 STOP 
+**)
diff --git a/test/testinterp/t172-pushenvacc3.ml b/test/testinterp/t172-pushenvacc3.ml
new file mode 100644
index 00000000..093f7f1e
--- /dev/null
+++ b/test/testinterp/t172-pushenvacc3.ml
@@ -0,0 +1,42 @@
+open Lib;;
+let x = 5 in
+let y = 4 in
+let z = 3 in
+let f _ = z + y + x in
+if f 0 <> 12 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 18
+      11 ENVACC1 
+      12 PUSHENVACC2 
+      13 PUSHENVACC3 
+      14 ADDINT 
+      15 ADDINT 
+      16 RETURN 1
+      18 CONSTINT 5
+      20 PUSHCONSTINT 4
+      22 PUSHCONST3 
+      23 PUSHACC0 
+      24 PUSHACC2 
+      25 PUSHACC4 
+      26 CLOSURE 3, 11
+      29 PUSHCONSTINT 12
+      31 PUSHCONST0 
+      32 PUSHACC2 
+      33 APPLY1 
+      34 NEQ 
+      35 BRANCHIFNOT 42
+      37 GETGLOBAL Not_found
+      39 MAKEBLOCK1 0
+      41 RAISE 
+      42 POP 4
+      44 ATOM0 
+      45 SETGLOBAL T172-pushenvacc3
+      47 STOP 
+**)
diff --git a/test/testinterp/t172-pushenvacc4.ml b/test/testinterp/t172-pushenvacc4.ml
new file mode 100644
index 00000000..154c4a47
--- /dev/null
+++ b/test/testinterp/t172-pushenvacc4.ml
@@ -0,0 +1,47 @@
+open Lib;;
+let x = 5 in
+let y = 4 in
+let z = 3 in
+let a = 2 in
+let f _ = a + z + y + x in
+if f 0 <> 14 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 21
+      11 ENVACC1 
+      12 PUSHENVACC2 
+      13 PUSHENVACC3 
+      14 PUSHENVACC 4
+      16 ADDINT 
+      17 ADDINT 
+      18 ADDINT 
+      19 RETURN 1
+      21 CONSTINT 5
+      23 PUSHCONSTINT 4
+      25 PUSHCONST3 
+      26 PUSHCONST2 
+      27 PUSHACC0 
+      28 PUSHACC2 
+      29 PUSHACC4 
+      30 PUSHACC6 
+      31 CLOSURE 4, 11
+      34 PUSHCONSTINT 14
+      36 PUSHCONST0 
+      37 PUSHACC2 
+      38 APPLY1 
+      39 NEQ 
+      40 BRANCHIFNOT 47
+      42 GETGLOBAL Not_found
+      44 MAKEBLOCK1 0
+      46 RAISE 
+      47 POP 5
+      49 ATOM0 
+      50 SETGLOBAL T172-pushenvacc4
+      52 STOP 
+**)
diff --git a/test/testinterp/t173-pushenvacc.ml b/test/testinterp/t173-pushenvacc.ml
new file mode 100644
index 00000000..0d858b4a
--- /dev/null
+++ b/test/testinterp/t173-pushenvacc.ml
@@ -0,0 +1,52 @@
+open Lib;;
+let x = 5 in
+let y = 4 in
+let z = 3 in
+let a = 2 in
+let b = 1 in
+let f _ = b + a + z + y + x in
+if f 0 <> 15 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 24
+      11 ENVACC1 
+      12 PUSHENVACC2 
+      13 PUSHENVACC3 
+      14 PUSHENVACC 4
+      16 PUSHENVACC 5
+      18 ADDINT 
+      19 ADDINT 
+      20 ADDINT 
+      21 ADDINT 
+      22 RETURN 1
+      24 CONSTINT 5
+      26 PUSHCONSTINT 4
+      28 PUSHCONST3 
+      29 PUSHCONST2 
+      30 PUSHCONST1 
+      31 PUSHACC0 
+      32 PUSHACC2 
+      33 PUSHACC4 
+      34 PUSHACC6 
+      35 PUSHACC 8
+      37 CLOSURE 5, 11
+      40 PUSHCONSTINT 15
+      42 PUSHCONST0 
+      43 PUSHACC2 
+      44 APPLY1 
+      45 NEQ 
+      46 BRANCHIFNOT 53
+      48 GETGLOBAL Not_found
+      50 MAKEBLOCK1 0
+      52 RAISE 
+      53 POP 6
+      55 ATOM0 
+      56 SETGLOBAL T173-pushenvacc
+      58 STOP 
+**)
diff --git a/test/testinterp/t180-appterm1.ml b/test/testinterp/t180-appterm1.ml
new file mode 100644
index 00000000..6b82f51b
--- /dev/null
+++ b/test/testinterp/t180-appterm1.ml
@@ -0,0 +1,35 @@
+open Lib;;
+let f _ = 12 in
+let g _ = f 0 in
+if g 0 <> 12 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 19
+      11 CONST0 
+      12 PUSHENVACC1 
+      13 APPTERM1 2
+      15 CONSTINT 12
+      17 RETURN 1
+      19 CLOSURE 0, 15
+      22 PUSHACC0 
+      23 CLOSURE 1, 11
+      26 PUSHCONSTINT 12
+      28 PUSHCONST0 
+      29 PUSHACC2 
+      30 APPLY1 
+      31 NEQ 
+      32 BRANCHIFNOT 39
+      34 GETGLOBAL Not_found
+      36 MAKEBLOCK1 0
+      38 RAISE 
+      39 POP 2
+      41 ATOM0 
+      42 SETGLOBAL T180-appterm1
+      44 STOP 
+**)
diff --git a/test/testinterp/t180-appterm2.ml b/test/testinterp/t180-appterm2.ml
new file mode 100644
index 00000000..28f32a93
--- /dev/null
+++ b/test/testinterp/t180-appterm2.ml
@@ -0,0 +1,38 @@
+open Lib;;
+let f _ _ = 12 in
+let g _ = f 0 0 in
+if g 0 <> 12 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 23
+      11 CONST0 
+      12 PUSHCONST0 
+      13 PUSHENVACC1 
+      14 APPTERM2 3
+      16 RESTART 
+      17 GRAB 1
+      19 CONSTINT 12
+      21 RETURN 2
+      23 CLOSURE 0, 17
+      26 PUSHACC0 
+      27 CLOSURE 1, 11
+      30 PUSHCONSTINT 12
+      32 PUSHCONST0 
+      33 PUSHACC2 
+      34 APPLY1 
+      35 NEQ 
+      36 BRANCHIFNOT 43
+      38 GETGLOBAL Not_found
+      40 MAKEBLOCK1 0
+      42 RAISE 
+      43 POP 2
+      45 ATOM0 
+      46 SETGLOBAL T180-appterm2
+      48 STOP 
+**)
diff --git a/test/testinterp/t180-appterm3.ml b/test/testinterp/t180-appterm3.ml
new file mode 100644
index 00000000..fe8a0bd5
--- /dev/null
+++ b/test/testinterp/t180-appterm3.ml
@@ -0,0 +1,39 @@
+open Lib;;
+let f _ _ _ = 13 in
+let g _ = f 0 0 0 in
+if g 0 <> 13 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 24
+      11 CONST0 
+      12 PUSHCONST0 
+      13 PUSHCONST0 
+      14 PUSHENVACC1 
+      15 APPTERM3 4
+      17 RESTART 
+      18 GRAB 2
+      20 CONSTINT 13
+      22 RETURN 3
+      24 CLOSURE 0, 18
+      27 PUSHACC0 
+      28 CLOSURE 1, 11
+      31 PUSHCONSTINT 13
+      33 PUSHCONST0 
+      34 PUSHACC2 
+      35 APPLY1 
+      36 NEQ 
+      37 BRANCHIFNOT 44
+      39 GETGLOBAL Not_found
+      41 MAKEBLOCK1 0
+      43 RAISE 
+      44 POP 2
+      46 ATOM0 
+      47 SETGLOBAL T180-appterm3
+      49 STOP 
+**)
diff --git a/test/testinterp/t181-appterm.ml b/test/testinterp/t181-appterm.ml
new file mode 100644
index 00000000..03127bc8
--- /dev/null
+++ b/test/testinterp/t181-appterm.ml
@@ -0,0 +1,40 @@
+open Lib;;
+let f _ _ _ _ = -10 in
+let g _ = f 0 0 0 0 in
+if g 0 <> -10 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 26
+      11 CONST0 
+      12 PUSHCONST0 
+      13 PUSHCONST0 
+      14 PUSHCONST0 
+      15 PUSHENVACC1 
+      16 APPTERM 4, 5
+      19 RESTART 
+      20 GRAB 3
+      22 CONSTINT -10
+      24 RETURN 4
+      26 CLOSURE 0, 20
+      29 PUSHACC0 
+      30 CLOSURE 1, 11
+      33 PUSHCONSTINT -10
+      35 PUSHCONST0 
+      36 PUSHACC2 
+      37 APPLY1 
+      38 NEQ 
+      39 BRANCHIFNOT 46
+      41 GETGLOBAL Not_found
+      43 MAKEBLOCK1 0
+      45 RAISE 
+      46 POP 2
+      48 ATOM0 
+      49 SETGLOBAL T181-appterm
+      51 STOP 
+**)
diff --git a/test/testinterp/t190-makefloatblock-1.ml b/test/testinterp/t190-makefloatblock-1.ml
new file mode 100644
index 00000000..f63c6cd8
--- /dev/null
+++ b/test/testinterp/t190-makefloatblock-1.ml
@@ -0,0 +1,17 @@
+open Lib;;
+let x = 0.0 in [| x |];;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL 0
+      11 PUSHACC0 
+      12 MAKEFLOATBLOCK 1
+      14 POP 1
+      16 ATOM0 
+      17 SETGLOBAL T190-makefloatblock-1
+      19 STOP 
+**)
diff --git a/test/testinterp/t190-makefloatblock-2.ml b/test/testinterp/t190-makefloatblock-2.ml
new file mode 100644
index 00000000..53b97f5d
--- /dev/null
+++ b/test/testinterp/t190-makefloatblock-2.ml
@@ -0,0 +1,18 @@
+open Lib;;
+let x = 0.0 in [| x; x |];;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL 0
+      11 PUSHACC0 
+      12 PUSHACC1 
+      13 MAKEFLOATBLOCK 2
+      15 POP 1
+      17 ATOM0 
+      18 SETGLOBAL T190-makefloatblock-2
+      20 STOP 
+**)
diff --git a/test/testinterp/t190-makefloatblock-3.ml b/test/testinterp/t190-makefloatblock-3.ml
new file mode 100644
index 00000000..cebccaa3
--- /dev/null
+++ b/test/testinterp/t190-makefloatblock-3.ml
@@ -0,0 +1,19 @@
+open Lib;;
+let x = 0.0 in [| x; x; x |];;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL 0
+      11 PUSHACC0 
+      12 PUSHACC1 
+      13 PUSHACC2 
+      14 MAKEFLOATBLOCK 3
+      16 POP 1
+      18 ATOM0 
+      19 SETGLOBAL T190-makefloatblock-3
+      21 STOP 
+**)
diff --git a/test/testinterp/t191-vectlength.ml b/test/testinterp/t191-vectlength.ml
new file mode 100644
index 00000000..16f7d783
--- /dev/null
+++ b/test/testinterp/t191-vectlength.ml
@@ -0,0 +1,26 @@
+open Lib;;
+let x = 0.0 in
+if Array.length [| x |] <> 1 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL 0
+      11 PUSHCONST1 
+      12 PUSHACC1 
+      13 MAKEFLOATBLOCK 1
+      15 VECTLENGTH 
+      16 NEQ 
+      17 BRANCHIFNOT 24
+      19 GETGLOBAL Not_found
+      21 MAKEBLOCK1 0
+      23 RAISE 
+      24 POP 1
+      26 ATOM0 
+      27 SETGLOBAL T191-vectlength
+      29 STOP 
+**)
diff --git a/test/testinterp/t192-getfloatfield-1.ml b/test/testinterp/t192-getfloatfield-1.ml
new file mode 100644
index 00000000..ba002b20
--- /dev/null
+++ b/test/testinterp/t192-getfloatfield-1.ml
@@ -0,0 +1,23 @@
+open Lib;;
+type t = { a : float; b : float };;
+
+if { a = 0.1; b = 0.2 }.a <> 0.1 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL 0.1
+      11 PUSHGETGLOBAL [|0.1, 0.2|]
+      13 GETFLOATFIELD 0
+      15 C_CALL2 neq_float
+      17 BRANCHIFNOT 24
+      19 GETGLOBAL Not_found
+      21 MAKEBLOCK1 0
+      23 RAISE 
+      24 ATOM0 
+      25 SETGLOBAL T192-getfloatfield-1
+      27 STOP 
+**)
diff --git a/test/testinterp/t192-getfloatfield-2.ml b/test/testinterp/t192-getfloatfield-2.ml
new file mode 100644
index 00000000..89230da3
--- /dev/null
+++ b/test/testinterp/t192-getfloatfield-2.ml
@@ -0,0 +1,23 @@
+open Lib;;
+type t = { a : float; b : float };;
+
+if { a = 0.1; b = 0.2 }.b <> 0.2 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL 0.2
+      11 PUSHGETGLOBAL [|0.1, 0.2|]
+      13 GETFLOATFIELD 1
+      15 C_CALL2 neq_float
+      17 BRANCHIFNOT 24
+      19 GETGLOBAL Not_found
+      21 MAKEBLOCK1 0
+      23 RAISE 
+      24 ATOM0 
+      25 SETGLOBAL T192-getfloatfield-2
+      27 STOP 
+**)
diff --git a/test/testinterp/t193-setfloatfield-1.ml b/test/testinterp/t193-setfloatfield-1.ml
new file mode 100644
index 00000000..b488e7da
--- /dev/null
+++ b/test/testinterp/t193-setfloatfield-1.ml
@@ -0,0 +1,36 @@
+open Lib;;
+type t = {
+  mutable a : float;
+  mutable b : float;
+};;
+
+let x = { a = 0.1; b = 0.2 } in
+x.a <- 0.3;
+if x.a <> 0.3 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL 0.2
+      11 PUSHGETGLOBAL 0.1
+      13 MAKEFLOATBLOCK 2
+      15 PUSHGETGLOBAL 0.3
+      17 PUSHACC1 
+      18 SETFLOATFIELD 0
+      20 GETGLOBAL 0.3
+      22 PUSHACC1 
+      23 GETFLOATFIELD 0
+      25 C_CALL2 neq_float
+      27 BRANCHIFNOT 34
+      29 GETGLOBAL Not_found
+      31 MAKEBLOCK1 0
+      33 RAISE 
+      34 POP 1
+      36 ATOM0 
+      37 SETGLOBAL T193-setfloatfield-1
+      39 STOP 
+**)
diff --git a/test/testinterp/t193-setfloatfield-2.ml b/test/testinterp/t193-setfloatfield-2.ml
new file mode 100644
index 00000000..7dde0a2c
--- /dev/null
+++ b/test/testinterp/t193-setfloatfield-2.ml
@@ -0,0 +1,36 @@
+open Lib;;
+type t = {
+  mutable a : float;
+  mutable b : float;
+};;
+
+let x = { a = 0.1; b = 0.2 } in
+x.b <- 0.3;
+if x.b <> 0.3 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL 0.2
+      11 PUSHGETGLOBAL 0.1
+      13 MAKEFLOATBLOCK 2
+      15 PUSHGETGLOBAL 0.3
+      17 PUSHACC1 
+      18 SETFLOATFIELD 1
+      20 GETGLOBAL 0.3
+      22 PUSHACC1 
+      23 GETFLOATFIELD 1
+      25 C_CALL2 neq_float
+      27 BRANCHIFNOT 34
+      29 GETGLOBAL Not_found
+      31 MAKEBLOCK1 0
+      33 RAISE 
+      34 POP 1
+      36 ATOM0 
+      37 SETGLOBAL T193-setfloatfield-2
+      39 STOP 
+**)
diff --git a/test/testinterp/t200-getfield0.ml b/test/testinterp/t200-getfield0.ml
new file mode 100644
index 00000000..14ce1d54
--- /dev/null
+++ b/test/testinterp/t200-getfield0.ml
@@ -0,0 +1,25 @@
+open Lib;;
+type t = {
+  a : int;
+};;
+
+if { a = 7 }.a <> 7 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 7
+      11 PUSHGETGLOBAL <0>(7)
+      13 GETFIELD0 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T200-getfield0
+      25 STOP 
+**)
diff --git a/test/testinterp/t200-getfield1.ml b/test/testinterp/t200-getfield1.ml
new file mode 100644
index 00000000..f4e2e019
--- /dev/null
+++ b/test/testinterp/t200-getfield1.ml
@@ -0,0 +1,26 @@
+open Lib;;
+type t = {
+  a : int;
+  b : int;
+};;
+
+if { a = 7; b = 6 }.b <> 6 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 6
+      11 PUSHGETGLOBAL <0>(7, 6)
+      13 GETFIELD1 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T200-getfield1
+      25 STOP 
+**)
diff --git a/test/testinterp/t200-getfield2.ml b/test/testinterp/t200-getfield2.ml
new file mode 100644
index 00000000..df5c7172
--- /dev/null
+++ b/test/testinterp/t200-getfield2.ml
@@ -0,0 +1,27 @@
+open Lib;;
+type t = {
+  a : int;
+  b : int;
+  c : int;
+};;
+
+if { a = 7; b = 6; c = 5 }.c <> 5 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 5
+      11 PUSHGETGLOBAL <0>(7, 6, 5)
+      13 GETFIELD2 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T200-getfield2
+      25 STOP 
+**)
diff --git a/test/testinterp/t200-getfield3.ml b/test/testinterp/t200-getfield3.ml
new file mode 100644
index 00000000..a0376a1f
--- /dev/null
+++ b/test/testinterp/t200-getfield3.ml
@@ -0,0 +1,28 @@
+open Lib;;
+type t = {
+  a : int;
+  b : int;
+  c : int;
+  d : int;
+};;
+
+if { a = 7; b = 6; c = 5; d = 4 }.d <> 4 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 4
+      11 PUSHGETGLOBAL <0>(7, 6, 5, 4)
+      13 GETFIELD3 
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T200-getfield3
+      25 STOP 
+**)
diff --git a/test/testinterp/t201-getfield.ml b/test/testinterp/t201-getfield.ml
new file mode 100644
index 00000000..0fbbc63f
--- /dev/null
+++ b/test/testinterp/t201-getfield.ml
@@ -0,0 +1,29 @@
+open Lib;;
+type t = {
+  a : int;
+  b : int;
+  c : int;
+  d : int;
+  e : int;
+};;
+
+if { a = 7; b = 6; c = 5; d = 4; e = 3 }.e <> 3 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST3 
+      10 PUSHGETGLOBAL <0>(7, 6, 5, 4, 3)
+      12 GETFIELD 4
+      14 NEQ 
+      15 BRANCHIFNOT 22
+      17 GETGLOBAL Not_found
+      19 MAKEBLOCK1 0
+      21 RAISE 
+      22 ATOM0 
+      23 SETGLOBAL T201-getfield
+      25 STOP 
+**)
diff --git a/test/testinterp/t210-setfield0.ml b/test/testinterp/t210-setfield0.ml
new file mode 100644
index 00000000..aa31d41f
--- /dev/null
+++ b/test/testinterp/t210-setfield0.ml
@@ -0,0 +1,36 @@
+open Lib;;
+type t = {
+  mutable a : int;
+};;
+
+let x = {a = 7} in
+x.a <- 11;
+if x.a <> 11 then raise Not_found;
+x
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 7
+      11 MAKEBLOCK1 0
+      13 PUSHCONSTINT 11
+      15 PUSHACC1 
+      16 SETFIELD0 
+      17 CONSTINT 11
+      19 PUSHACC1 
+      20 GETFIELD0 
+      21 NEQ 
+      22 BRANCHIFNOT 29
+      24 GETGLOBAL Not_found
+      26 MAKEBLOCK1 0
+      28 RAISE 
+      29 ACC0 
+      30 POP 1
+      32 ATOM0 
+      33 SETGLOBAL T210-setfield0
+      35 STOP 
+**)
diff --git a/test/testinterp/t210-setfield1.ml b/test/testinterp/t210-setfield1.ml
new file mode 100644
index 00000000..0d8e1676
--- /dev/null
+++ b/test/testinterp/t210-setfield1.ml
@@ -0,0 +1,38 @@
+open Lib;;
+type t = {
+  mutable a : int;
+  mutable b : int;
+};;
+
+let x = {a = 7; b = 6} in
+x.b <- 11;
+if x.b <> 11 then raise Not_found;
+x
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 6
+      11 PUSHCONSTINT 7
+      13 MAKEBLOCK2 0
+      15 PUSHCONSTINT 11
+      17 PUSHACC1 
+      18 SETFIELD1 
+      19 CONSTINT 11
+      21 PUSHACC1 
+      22 GETFIELD1 
+      23 NEQ 
+      24 BRANCHIFNOT 31
+      26 GETGLOBAL Not_found
+      28 MAKEBLOCK1 0
+      30 RAISE 
+      31 ACC0 
+      32 POP 1
+      34 ATOM0 
+      35 SETGLOBAL T210-setfield1
+      37 STOP 
+**)
diff --git a/test/testinterp/t210-setfield2.ml b/test/testinterp/t210-setfield2.ml
new file mode 100644
index 00000000..727691d1
--- /dev/null
+++ b/test/testinterp/t210-setfield2.ml
@@ -0,0 +1,40 @@
+open Lib;;
+type t = {
+  mutable a : int;
+  mutable b : int;
+  mutable c : int;
+};;
+
+let x = {a = 7; b = 6; c = 5} in
+x.c <- 11;
+if x.c <> 11 then raise Not_found;
+x
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 5
+      11 PUSHCONSTINT 6
+      13 PUSHCONSTINT 7
+      15 MAKEBLOCK3 0
+      17 PUSHCONSTINT 11
+      19 PUSHACC1 
+      20 SETFIELD2 
+      21 CONSTINT 11
+      23 PUSHACC1 
+      24 GETFIELD2 
+      25 NEQ 
+      26 BRANCHIFNOT 33
+      28 GETGLOBAL Not_found
+      30 MAKEBLOCK1 0
+      32 RAISE 
+      33 ACC0 
+      34 POP 1
+      36 ATOM0 
+      37 SETGLOBAL T210-setfield2
+      39 STOP 
+**)
diff --git a/test/testinterp/t210-setfield3.ml b/test/testinterp/t210-setfield3.ml
new file mode 100644
index 00000000..d50d2c2a
--- /dev/null
+++ b/test/testinterp/t210-setfield3.ml
@@ -0,0 +1,42 @@
+open Lib;;
+type t = {
+  mutable a : int;
+  mutable b : int;
+  mutable c : int;
+  mutable d : int;
+};;
+
+let x = {a = 7; b = 6; c = 5; d = 4} in
+x.d <- 11;
+if x.d <> 11 then raise Not_found;
+x
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 4
+      11 PUSHCONSTINT 5
+      13 PUSHCONSTINT 6
+      15 PUSHCONSTINT 7
+      17 MAKEBLOCK 4, 0
+      20 PUSHCONSTINT 11
+      22 PUSHACC1 
+      23 SETFIELD3 
+      24 CONSTINT 11
+      26 PUSHACC1 
+      27 GETFIELD3 
+      28 NEQ 
+      29 BRANCHIFNOT 36
+      31 GETGLOBAL Not_found
+      33 MAKEBLOCK1 0
+      35 RAISE 
+      36 ACC0 
+      37 POP 1
+      39 ATOM0 
+      40 SETGLOBAL T210-setfield3
+      42 STOP 
+**)
diff --git a/test/testinterp/t211-setfield.ml b/test/testinterp/t211-setfield.ml
new file mode 100644
index 00000000..69c445e1
--- /dev/null
+++ b/test/testinterp/t211-setfield.ml
@@ -0,0 +1,44 @@
+open Lib;;
+type t = {
+  mutable a : int;
+  mutable b : int;
+  mutable c : int;
+  mutable d : int;
+  mutable e : int;
+};;
+
+let x = {a = 7; b = 6; c = 5; d = 4; e = 5} in
+x.e <- 11;
+if x.e <> 11 then raise Not_found;
+x
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 5
+      11 PUSHCONSTINT 4
+      13 PUSHCONSTINT 5
+      15 PUSHCONSTINT 6
+      17 PUSHCONSTINT 7
+      19 MAKEBLOCK 5, 0
+      22 PUSHCONSTINT 11
+      24 PUSHACC1 
+      25 SETFIELD 4
+      27 CONSTINT 11
+      29 PUSHACC1 
+      30 GETFIELD 4
+      32 NEQ 
+      33 BRANCHIFNOT 40
+      35 GETGLOBAL Not_found
+      37 MAKEBLOCK1 0
+      39 RAISE 
+      40 ACC0 
+      41 POP 1
+      43 ATOM0 
+      44 SETGLOBAL T211-setfield
+      46 STOP 
+**)
diff --git a/test/testinterp/t220-assign.ml b/test/testinterp/t220-assign.ml
new file mode 100644
index 00000000..769f8fb2
--- /dev/null
+++ b/test/testinterp/t220-assign.ml
@@ -0,0 +1,27 @@
+open Lib;;
+let x = ref 1 in
+x := 3;
+if !x <> 3 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST1 
+      10 PUSHCONST3 
+      11 ASSIGN 0
+      13 CONST3 
+      14 PUSHACC1 
+      15 NEQ 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 POP 1
+      25 ATOM0 
+      26 SETGLOBAL T220-assign
+      28 STOP 
+**)
diff --git a/test/testinterp/t230-check_signals.ml b/test/testinterp/t230-check_signals.ml
new file mode 100644
index 00000000..2c2b5d77
--- /dev/null
+++ b/test/testinterp/t230-check_signals.ml
@@ -0,0 +1,28 @@
+open Lib;;
+for i = 0 to 0 do () done;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 PUSHCONST0 
+      11 PUSH 
+      12 BRANCH 21
+      14 CHECK_SIGNALS 
+      15 CONST0 
+      16 ACC1 
+      17 OFFSETINT 1
+      19 ASSIGN 1
+      21 ACC0 
+      22 PUSHACC2 
+      23 LEINT 
+      24 BRANCHIF 14
+      26 CONST0 
+      27 POP 2
+      29 ATOM0 
+      30 SETGLOBAL T230-check_signals
+      32 STOP 
+**)
diff --git a/test/testinterp/t240-c_call1.ml b/test/testinterp/t240-c_call1.ml
new file mode 100644
index 00000000..3c7508cb
--- /dev/null
+++ b/test/testinterp/t240-c_call1.ml
@@ -0,0 +1,21 @@
+open Lib;;
+if Pervasives.int_of_string "123" <> 123 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 123
+      11 PUSHGETGLOBAL "123"
+      13 C_CALL1 int_of_string
+      15 NEQ 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 ATOM0 
+      24 SETGLOBAL T240-c_call1
+      26 STOP 
+**)
diff --git a/test/testinterp/t240-c_call2.ml b/test/testinterp/t240-c_call2.ml
new file mode 100644
index 00000000..23c98436
--- /dev/null
+++ b/test/testinterp/t240-c_call2.ml
@@ -0,0 +1,22 @@
+open Lib;;
+if Pervasives.compare 1 2 <> -1 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT -1
+      11 PUSHCONST2 
+      12 PUSHCONST1 
+      13 C_CALL2 compare
+      15 NEQ 
+      16 BRANCHIFNOT 23
+      18 GETGLOBAL Not_found
+      20 MAKEBLOCK1 0
+      22 RAISE 
+      23 ATOM0 
+      24 SETGLOBAL T240-c_call2
+      26 STOP 
+**)
diff --git a/test/testinterp/t240-c_call3.ml b/test/testinterp/t240-c_call3.ml
new file mode 100644
index 00000000..707bc7ee
--- /dev/null
+++ b/test/testinterp/t240-c_call3.ml
@@ -0,0 +1,23 @@
+open Lib;;
+if Hashtbl.hash_param 5 6 [1;2;3] <> 196799 then raise Not_found;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 196799
+      11 PUSHGETGLOBAL <0>(1, <0>(2, <0>(3, 0)))
+      13 PUSHCONSTINT 6
+      15 PUSHCONSTINT 5
+      17 C_CALL3 hash_univ_param
+      19 NEQ 
+      20 BRANCHIFNOT 27
+      22 GETGLOBAL Not_found
+      24 MAKEBLOCK1 0
+      26 RAISE 
+      27 ATOM0 
+      28 SETGLOBAL T240-c_call3
+      30 STOP 
+**)
diff --git a/test/testinterp/t240-c_call4.ml b/test/testinterp/t240-c_call4.ml
new file mode 100644
index 00000000..2ab62d86
--- /dev/null
+++ b/test/testinterp/t240-c_call4.ml
@@ -0,0 +1,32 @@
+open Lib;;
+let s = "abcdefgh" in
+String.unsafe_fill s 0 6 'x';
+if s.[5] <> 'x' then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL "abcdefgh"
+      11 PUSHCONSTINT 120
+      13 PUSHCONSTINT 6
+      15 PUSHCONST0 
+      16 PUSHACC3 
+      17 C_CALL4 fill_string
+      19 CONSTINT 120
+      21 PUSHCONSTINT 5
+      23 PUSHACC2 
+      24 GETSTRINGCHAR 
+      25 NEQ 
+      26 BRANCHIFNOT 33
+      28 GETGLOBAL Not_found
+      30 MAKEBLOCK1 0
+      32 RAISE 
+      33 POP 1
+      35 ATOM0 
+      36 SETGLOBAL T240-c_call4
+      38 STOP 
+**)
diff --git a/test/testinterp/t240-c_call5.ml b/test/testinterp/t240-c_call5.ml
new file mode 100644
index 00000000..e817d550
--- /dev/null
+++ b/test/testinterp/t240-c_call5.ml
@@ -0,0 +1,33 @@
+open Lib;;
+let s = "abcdefgh" in
+String.unsafe_blit s 3 s 0 3;
+if s.[0] <> 'd' then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 GETGLOBAL "abcdefgh"
+      11 PUSHCONST3 
+      12 PUSHCONST0 
+      13 PUSHACC2 
+      14 PUSHCONST3 
+      15 PUSHACC4 
+      16 C_CALL5 blit_string
+      18 CONSTINT 100
+      20 PUSHCONST0 
+      21 PUSHACC2 
+      22 GETSTRINGCHAR 
+      23 NEQ 
+      24 BRANCHIFNOT 31
+      26 GETGLOBAL Not_found
+      28 MAKEBLOCK1 0
+      30 RAISE 
+      31 POP 1
+      33 ATOM0 
+      34 SETGLOBAL T240-c_call5
+      36 STOP 
+**)
diff --git a/test/testinterp/t250-closurerec-1.ml b/test/testinterp/t250-closurerec-1.ml
new file mode 100644
index 00000000..ded5036e
--- /dev/null
+++ b/test/testinterp/t250-closurerec-1.ml
@@ -0,0 +1,19 @@
+open Lib;;
+let rec f _ = 0;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 14
+      11 CONST0 
+      12 RETURN 1
+      14 CLOSUREREC 0, 11
+      18 ACC0 
+      19 MAKEBLOCK1 0
+      21 POP 1
+      23 SETGLOBAL T250-closurerec-1
+      25 STOP 
+**)
diff --git a/test/testinterp/t250-closurerec-2.ml b/test/testinterp/t250-closurerec-2.ml
new file mode 100644
index 00000000..97eac0c7
--- /dev/null
+++ b/test/testinterp/t250-closurerec-2.ml
@@ -0,0 +1,29 @@
+open Lib;;
+let rec f _ = 23 in
+if f 0 <> 23 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 15
+      11 CONSTINT 23
+      13 RETURN 1
+      15 CLOSUREREC 0, 11
+      19 CONSTINT 23
+      21 PUSHCONST0 
+      22 PUSHACC2 
+      23 APPLY1 
+      24 NEQ 
+      25 BRANCHIFNOT 32
+      27 GETGLOBAL Not_found
+      29 MAKEBLOCK1 0
+      31 RAISE 
+      32 POP 1
+      34 ATOM0 
+      35 SETGLOBAL T250-closurerec-2
+      37 STOP 
+**)
diff --git a/test/testinterp/t251-pushoffsetclosure0.ml b/test/testinterp/t251-pushoffsetclosure0.ml
new file mode 100644
index 00000000..b1c25555
--- /dev/null
+++ b/test/testinterp/t251-pushoffsetclosure0.ml
@@ -0,0 +1,39 @@
+open Lib;;
+let rec f = function
+  | 0 -> 13
+  | n -> f 0
+in
+if f 5 <> 13 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 24
+      11 CONST0 
+      12 PUSHACC1 
+      13 EQ 
+      14 BRANCHIFNOT 20
+      16 CONSTINT 13
+      18 RETURN 1
+      20 CONST0 
+      21 PUSHOFFSETCLOSURE0 
+      22 APPTERM1 2
+      24 CLOSUREREC 0, 11
+      28 CONSTINT 13
+      30 PUSHCONSTINT 5
+      32 PUSHACC2 
+      33 APPLY1 
+      34 NEQ 
+      35 BRANCHIFNOT 42
+      37 GETGLOBAL Not_found
+      39 MAKEBLOCK1 0
+      41 RAISE 
+      42 POP 1
+      44 ATOM0 
+      45 SETGLOBAL T251-pushoffsetclosure0
+      47 STOP 
+**)
diff --git a/test/testinterp/t251-pushoffsetclosure2.ml b/test/testinterp/t251-pushoffsetclosure2.ml
new file mode 100644
index 00000000..0fbdd6ea
--- /dev/null
+++ b/test/testinterp/t251-pushoffsetclosure2.ml
@@ -0,0 +1,34 @@
+open Lib;;
+let rec f _ = g 0
+    and g _ = 4
+in
+if f 5 <> 4 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 19
+      11 CONST0 
+      12 PUSHOFFSETCLOSURE2 
+      13 APPTERM1 2
+      15 CONSTINT 4
+      17 RETURN 1
+      19 CLOSUREREC 0, 11, 15
+      24 CONSTINT 4
+      26 PUSHCONSTINT 5
+      28 PUSHACC3 
+      29 APPLY1 
+      30 NEQ 
+      31 BRANCHIFNOT 38
+      33 GETGLOBAL Not_found
+      35 MAKEBLOCK1 0
+      37 RAISE 
+      38 POP 2
+      40 ATOM0 
+      41 SETGLOBAL T251-pushoffsetclosure2
+      43 STOP 
+**)
diff --git a/test/testinterp/t251-pushoffsetclosurem2.ml b/test/testinterp/t251-pushoffsetclosurem2.ml
new file mode 100644
index 00000000..41ec196c
--- /dev/null
+++ b/test/testinterp/t251-pushoffsetclosurem2.ml
@@ -0,0 +1,34 @@
+open Lib;;
+let rec f _ = 4
+    and g _ = f 2
+in
+if g 5 <> 4 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 19
+      11 CONSTINT 4
+      13 RETURN 1
+      15 CONST2 
+      16 PUSHOFFSETCLOSUREM2 
+      17 APPTERM1 2
+      19 CLOSUREREC 0, 11, 15
+      24 CONSTINT 4
+      26 PUSHCONSTINT 5
+      28 PUSHACC2 
+      29 APPLY1 
+      30 NEQ 
+      31 BRANCHIFNOT 38
+      33 GETGLOBAL Not_found
+      35 MAKEBLOCK1 0
+      37 RAISE 
+      38 POP 2
+      40 ATOM0 
+      41 SETGLOBAL T251-pushoffsetclosurem2
+      43 STOP 
+**)
diff --git a/test/testinterp/t252-pushoffsetclosure.ml b/test/testinterp/t252-pushoffsetclosure.ml
new file mode 100644
index 00000000..18871334
--- /dev/null
+++ b/test/testinterp/t252-pushoffsetclosure.ml
@@ -0,0 +1,38 @@
+open Lib;;
+let rec f x = x
+    and g _ = f 4
+    and h _ = f 6
+in
+if h 1 <> 6 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 25
+      11 ACC0 
+      12 RETURN 1
+      14 CONSTINT 4
+      16 PUSHOFFSETCLOSUREM2 
+      17 APPTERM1 2
+      19 CONSTINT 6
+      21 PUSHOFFSETCLOSURE -4
+      23 APPTERM1 2
+      25 CLOSUREREC 0, 11, 14, 19
+      31 CONSTINT 6
+      33 PUSHCONST1 
+      34 PUSHACC2 
+      35 APPLY1 
+      36 NEQ 
+      37 BRANCHIFNOT 44
+      39 GETGLOBAL Not_found
+      41 MAKEBLOCK1 0
+      43 RAISE 
+      44 POP 3
+      46 ATOM0 
+      47 SETGLOBAL T252-pushoffsetclosure
+      49 STOP 
+**)
diff --git a/test/testinterp/t253-offsetclosure0.ml b/test/testinterp/t253-offsetclosure0.ml
new file mode 100644
index 00000000..f6d12c6d
--- /dev/null
+++ b/test/testinterp/t253-offsetclosure0.ml
@@ -0,0 +1,34 @@
+open Lib;;
+let rec f _ = g f
+    and g _ = 10
+in
+if f 3 <> 10 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 19
+      11 OFFSETCLOSURE0 
+      12 PUSHOFFSETCLOSURE2 
+      13 APPTERM1 2
+      15 CONSTINT 10
+      17 RETURN 1
+      19 CLOSUREREC 0, 11, 15
+      24 CONSTINT 10
+      26 PUSHCONST3 
+      27 PUSHACC3 
+      28 APPLY1 
+      29 NEQ 
+      30 BRANCHIFNOT 37
+      32 GETGLOBAL Not_found
+      34 MAKEBLOCK1 0
+      36 RAISE 
+      37 POP 2
+      39 ATOM0 
+      40 SETGLOBAL T253-offsetclosure0
+      42 STOP 
+**)
diff --git a/test/testinterp/t253-offsetclosure2.ml b/test/testinterp/t253-offsetclosure2.ml
new file mode 100644
index 00000000..be940611
--- /dev/null
+++ b/test/testinterp/t253-offsetclosure2.ml
@@ -0,0 +1,34 @@
+open Lib;;
+let rec f _ = g
+    and g _ = 10
+in
+if f 3 4 <> 10 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 18
+      11 OFFSETCLOSURE2 
+      12 RETURN 1
+      14 CONSTINT 10
+      16 RETURN 1
+      18 CLOSUREREC 0, 11, 14
+      23 CONSTINT 10
+      25 PUSHCONSTINT 4
+      27 PUSHCONST3 
+      28 PUSHACC4 
+      29 APPLY2 
+      30 NEQ 
+      31 BRANCHIFNOT 38
+      33 GETGLOBAL Not_found
+      35 MAKEBLOCK1 0
+      37 RAISE 
+      38 POP 2
+      40 ATOM0 
+      41 SETGLOBAL T253-offsetclosure2
+      43 STOP 
+**)
diff --git a/test/testinterp/t253-offsetclosurem2.ml b/test/testinterp/t253-offsetclosurem2.ml
new file mode 100644
index 00000000..cec37931
--- /dev/null
+++ b/test/testinterp/t253-offsetclosurem2.ml
@@ -0,0 +1,34 @@
+open Lib;;
+let rec f _ = 11
+    and g _ = f
+in
+if g 3 4 <> 11 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 18
+      11 CONSTINT 11
+      13 RETURN 1
+      15 OFFSETCLOSUREM2 
+      16 RETURN 1
+      18 CLOSUREREC 0, 11, 15
+      23 CONSTINT 11
+      25 PUSHCONSTINT 4
+      27 PUSHCONST3 
+      28 PUSHACC3 
+      29 APPLY2 
+      30 NEQ 
+      31 BRANCHIFNOT 38
+      33 GETGLOBAL Not_found
+      35 MAKEBLOCK1 0
+      37 RAISE 
+      38 POP 2
+      40 ATOM0 
+      41 SETGLOBAL T253-offsetclosurem2
+      43 STOP 
+**)
diff --git a/test/testinterp/t254-offsetclosure.ml b/test/testinterp/t254-offsetclosure.ml
new file mode 100644
index 00000000..6da8c28c
--- /dev/null
+++ b/test/testinterp/t254-offsetclosure.ml
@@ -0,0 +1,37 @@
+open Lib;;
+let rec f _ = 11
+    and g _ = 0
+    and h _ = f
+in
+if h 3 4 <> 11 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 22
+      11 CONSTINT 11
+      13 RETURN 1
+      15 CONST0 
+      16 RETURN 1
+      18 OFFSETCLOSURE -4
+      20 RETURN 1
+      22 CLOSUREREC 0, 11, 15, 18
+      28 CONSTINT 11
+      30 PUSHCONSTINT 4
+      32 PUSHCONST3 
+      33 PUSHACC3 
+      34 APPLY2 
+      35 NEQ 
+      36 BRANCHIFNOT 43
+      38 GETGLOBAL Not_found
+      40 MAKEBLOCK1 0
+      42 RAISE 
+      43 POP 3
+      45 ATOM0 
+      46 SETGLOBAL T254-offsetclosure
+      48 STOP 
+**)
diff --git a/test/testinterp/t260-offsetref.ml b/test/testinterp/t260-offsetref.ml
new file mode 100644
index 00000000..968892ef
--- /dev/null
+++ b/test/testinterp/t260-offsetref.ml
@@ -0,0 +1,31 @@
+open Lib;;
+let x = ref 32 in
+incr x;
+if !x <> 33 then raise Not_found;
+x
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONSTINT 32
+      11 MAKEBLOCK1 0
+      13 PUSHACC0 
+      14 OFFSETREF 1
+      16 CONSTINT 33
+      18 PUSHACC1 
+      19 GETFIELD0 
+      20 NEQ 
+      21 BRANCHIFNOT 28
+      23 GETGLOBAL Not_found
+      25 MAKEBLOCK1 0
+      27 RAISE 
+      28 ACC0 
+      29 POP 1
+      31 ATOM0 
+      32 SETGLOBAL T260-offsetref
+      34 STOP 
+**)
diff --git a/test/testinterp/t270-push_retaddr.ml b/test/testinterp/t270-push_retaddr.ml
new file mode 100644
index 00000000..0c7fb369
--- /dev/null
+++ b/test/testinterp/t270-push_retaddr.ml
@@ -0,0 +1,36 @@
+open Lib;;
+let f a b c d = 123 in
+if f 0 1 2 3 <> 123 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 18
+      11 RESTART 
+      12 GRAB 3
+      14 CONSTINT 123
+      16 RETURN 4
+      18 CLOSURE 0, 12
+      21 PUSHCONSTINT 123
+      23 PUSH 
+      24 PUSH_RETADDR 34
+      26 CONST3 
+      27 PUSHCONST2 
+      28 PUSHCONST1 
+      29 PUSHCONST0 
+      30 PUSHACC 8
+      32 APPLY 4
+      34 NEQ 
+      35 BRANCHIFNOT 42
+      37 GETGLOBAL Not_found
+      39 MAKEBLOCK1 0
+      41 RAISE 
+      42 POP 1
+      44 ATOM0 
+      45 SETGLOBAL T270-push_retaddr
+      47 STOP 
+**)
diff --git a/test/testinterp/t300-getmethod.ml b/test/testinterp/t300-getmethod.ml
new file mode 100644
index 00000000..e7894735
--- /dev/null
+++ b/test/testinterp/t300-getmethod.ml
@@ -0,0 +1,5885 @@
+open Lib;;
+
+class c = object
+  method m = 23
+end;;
+
+let o = new c in
+if o#m <> 23 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 BRANCH 2177
+    1199 RESTART 
+    1200 GRAB 1
+    1202 ACC1 
+    1203 BRANCHIFNOT 1213
+    1205 ACC1 
+    1206 GETFIELD1 
+    1207 PUSHACC1 
+    1208 OFFSETINT 1
+    1210 PUSHOFFSETCLOSURE0 
+    1211 APPTERM2 4
+    1213 ACC0 
+    1214 RETURN 2
+    1216 RESTART 
+    1217 GRAB 1
+    1219 ACC0 
+    1220 BRANCHIFNOT 1251
+    1222 CONST0 
+    1223 PUSHACC2 
+    1224 EQ 
+    1225 BRANCHIFNOT 1231
+    1227 ACC0 
+    1228 GETFIELD0 
+    1229 RETURN 2
+    1231 CONST0 
+    1232 PUSHACC2 
+    1233 GTINT 
+    1234 BRANCHIFNOT 1244
+    1236 ACC1 
+    1237 OFFSETINT -1
+    1239 PUSHACC1 
+    1240 GETFIELD1 
+    1241 PUSHOFFSETCLOSURE0 
+    1242 APPTERM2 4
+    1244 GETGLOBAL "List.nth"
+    1246 PUSHGETGLOBALFIELD Pervasives, 2
+    1249 APPTERM1 3
+    1251 GETGLOBAL "nth"
+    1253 PUSHGETGLOBALFIELD Pervasives, 3
+    1256 APPTERM1 3
+    1258 RESTART 
+    1259 GRAB 1
+    1261 ACC0 
+    1262 BRANCHIFNOT 1274
+    1264 ACC1 
+    1265 PUSHACC1 
+    1266 GETFIELD0 
+    1267 MAKEBLOCK2 0
+    1269 PUSHACC1 
+    1270 GETFIELD1 
+    1271 PUSHOFFSETCLOSURE0 
+    1272 APPTERM2 4
+    1274 ACC1 
+    1275 RETURN 2
+    1277 ACC0 
+    1278 BRANCHIFNOT 1291
+    1280 ACC0 
+    1281 GETFIELD1 
+    1282 PUSHOFFSETCLOSURE0 
+    1283 APPLY1 
+    1284 PUSHACC1 
+    1285 GETFIELD0 
+    1286 PUSHGETGLOBALFIELD Pervasives, 16
+    1289 APPTERM2 3
+    1291 RETURN 1
+    1293 RESTART 
+    1294 GRAB 1
+    1296 ACC1 
+    1297 BRANCHIFNOT 1313
+    1299 ACC1 
+    1300 GETFIELD0 
+    1301 PUSHACC1 
+    1302 APPLY1 
+    1303 PUSHACC2 
+    1304 GETFIELD1 
+    1305 PUSHACC2 
+    1306 PUSHOFFSETCLOSURE0 
+    1307 APPLY2 
+    1308 PUSHACC1 
+    1309 MAKEBLOCK2 0
+    1311 POP 1
+    1313 RETURN 2
+    1315 RESTART 
+    1316 GRAB 1
+    1318 ACC1 
+    1319 BRANCHIFNOT 1331
+    1321 ACC1 
+    1322 GETFIELD0 
+    1323 PUSHACC1 
+    1324 APPLY1 
+    1325 ACC1 
+    1326 GETFIELD1 
+    1327 PUSHACC1 
+    1328 PUSHOFFSETCLOSURE0 
+    1329 APPTERM2 4
+    1331 RETURN 2
+    1333 RESTART 
+    1334 GRAB 2
+    1336 ACC2 
+    1337 BRANCHIFNOT 1350
+    1339 ACC2 
+    1340 GETFIELD1 
+    1341 PUSHACC3 
+    1342 GETFIELD0 
+    1343 PUSHACC3 
+    1344 PUSHACC3 
+    1345 APPLY2 
+    1346 PUSHACC2 
+    1347 PUSHOFFSETCLOSURE0 
+    1348 APPTERM3 6
+    1350 ACC1 
+    1351 RETURN 3
+    1353 RESTART 
+    1354 GRAB 2
+    1356 ACC1 
+    1357 BRANCHIFNOT 1370
+    1359 ACC2 
+    1360 PUSHACC2 
+    1361 GETFIELD1 
+    1362 PUSHACC2 
+    1363 PUSHOFFSETCLOSURE0 
+    1364 APPLY3 
+    1365 PUSHACC2 
+    1366 GETFIELD0 
+    1367 PUSHACC2 
+    1368 APPTERM2 5
+    1370 ACC2 
+    1371 RETURN 3
+    1373 RESTART 
+    1374 GRAB 2
+    1376 ACC1 
+    1377 BRANCHIFNOT 1400
+    1379 ACC2 
+    1380 BRANCHIFNOT 1407
+    1382 ACC2 
+    1383 GETFIELD0 
+    1384 PUSHACC2 
+    1385 GETFIELD0 
+    1386 PUSHACC2 
+    1387 APPLY2 
+    1388 PUSHACC3 
+    1389 GETFIELD1 
+    1390 PUSHACC3 
+    1391 GETFIELD1 
+    1392 PUSHACC3 
+    1393 PUSHOFFSETCLOSURE0 
+    1394 APPLY3 
+    1395 PUSHACC1 
+    1396 MAKEBLOCK2 0
+    1398 RETURN 4
+    1400 ACC2 
+    1401 BRANCHIFNOT 1405
+    1403 BRANCH 1407
+    1405 RETURN 3
+    1407 GETGLOBAL "List.map2"
+    1409 PUSHGETGLOBALFIELD Pervasives, 2
+    1412 APPTERM1 4
+    1414 RESTART 
+    1415 GRAB 2
+    1417 ACC1 
+    1418 BRANCHIFNOT 1437
+    1420 ACC2 
+    1421 BRANCHIFNOT 1444
+    1423 ACC2 
+    1424 GETFIELD0 
+    1425 PUSHACC2 
+    1426 GETFIELD0 
+    1427 PUSHACC2 
+    1428 APPLY2 
+    1429 ACC2 
+    1430 GETFIELD1 
+    1431 PUSHACC2 
+    1432 GETFIELD1 
+    1433 PUSHACC2 
+    1434 PUSHOFFSETCLOSURE0 
+    1435 APPTERM3 6
+    1437 ACC2 
+    1438 BRANCHIFNOT 1442
+    1440 BRANCH 1444
+    1442 RETURN 3
+    1444 GETGLOBAL "List.iter2"
+    1446 PUSHGETGLOBALFIELD Pervasives, 2
+    1449 APPTERM1 4
+    1451 RESTART 
+    1452 GRAB 3
+    1454 ACC2 
+    1455 BRANCHIFNOT 1476
+    1457 ACC3 
+    1458 BRANCHIFNOT 1482
+    1460 ACC3 
+    1461 GETFIELD1 
+    1462 PUSHACC3 
+    1463 GETFIELD1 
+    1464 PUSHACC5 
+    1465 GETFIELD0 
+    1466 PUSHACC5 
+    1467 GETFIELD0 
+    1468 PUSHACC5 
+    1469 PUSHACC5 
+    1470 APPLY3 
+    1471 PUSHACC3 
+    1472 PUSHOFFSETCLOSURE0 
+    1473 APPTERM 4, 8
+    1476 ACC3 
+    1477 BRANCHIF 1482
+    1479 ACC1 
+    1480 RETURN 4
+    1482 GETGLOBAL "List.fold_left2"
+    1484 PUSHGETGLOBALFIELD Pervasives, 2
+    1487 APPTERM1 5
+    1489 RESTART 
+    1490 GRAB 3
+    1492 ACC1 
+    1493 BRANCHIFNOT 1516
+    1495 ACC2 
+    1496 BRANCHIFNOT 1522
+    1498 PUSH_RETADDR 1509
+    1500 ACC6 
+    1501 PUSHACC6 
+    1502 GETFIELD1 
+    1503 PUSHACC6 
+    1504 GETFIELD1 
+    1505 PUSHACC6 
+    1506 PUSHOFFSETCLOSURE0 
+    1507 APPLY 4
+    1509 PUSHACC3 
+    1510 GETFIELD0 
+    1511 PUSHACC3 
+    1512 GETFIELD0 
+    1513 PUSHACC3 
+    1514 APPTERM3 7
+    1516 ACC2 
+    1517 BRANCHIF 1522
+    1519 ACC3 
+    1520 RETURN 4
+    1522 GETGLOBAL "List.fold_right2"
+    1524 PUSHGETGLOBALFIELD Pervasives, 2
+    1527 APPTERM1 5
+    1529 RESTART 
+    1530 GRAB 1
+    1532 ACC1 
+    1533 BRANCHIFNOT 1549
+    1535 ACC1 
+    1536 GETFIELD0 
+    1537 PUSHACC1 
+    1538 APPLY1 
+    1539 BRANCHIFNOT 1547
+    1541 ACC1 
+    1542 GETFIELD1 
+    1543 PUSHACC1 
+    1544 PUSHOFFSETCLOSURE0 
+    1545 APPTERM2 4
+    1547 RETURN 2
+    1549 CONST1 
+    1550 RETURN 2
+    1552 RESTART 
+    1553 GRAB 1
+    1555 ACC1 
+    1556 BRANCHIFNOT 1570
+    1558 ACC1 
+    1559 GETFIELD0 
+    1560 PUSHACC1 
+    1561 APPLY1 
+    1562 BRANCHIF 1570
+    1564 ACC1 
+    1565 GETFIELD1 
+    1566 PUSHACC1 
+    1567 PUSHOFFSETCLOSURE0 
+    1568 APPTERM2 4
+    1570 RETURN 2
+    1572 RESTART 
+    1573 GRAB 2
+    1575 ACC1 
+    1576 BRANCHIFNOT 1599
+    1578 ACC2 
+    1579 BRANCHIFNOT 1605
+    1581 ACC2 
+    1582 GETFIELD0 
+    1583 PUSHACC2 
+    1584 GETFIELD0 
+    1585 PUSHACC2 
+    1586 APPLY2 
+    1587 BRANCHIFNOT 1597
+    1589 ACC2 
+    1590 GETFIELD1 
+    1591 PUSHACC2 
+    1592 GETFIELD1 
+    1593 PUSHACC2 
+    1594 PUSHOFFSETCLOSURE0 
+    1595 APPTERM3 6
+    1597 RETURN 3
+    1599 ACC2 
+    1600 BRANCHIF 1605
+    1602 CONST1 
+    1603 RETURN 3
+    1605 GETGLOBAL "List.for_all2"
+    1607 PUSHGETGLOBALFIELD Pervasives, 2
+    1610 APPTERM1 4
+    1612 RESTART 
+    1613 GRAB 2
+    1615 ACC1 
+    1616 BRANCHIFNOT 1639
+    1618 ACC2 
+    1619 BRANCHIFNOT 1646
+    1621 ACC2 
+    1622 GETFIELD0 
+    1623 PUSHACC2 
+    1624 GETFIELD0 
+    1625 PUSHACC2 
+    1626 APPLY2 
+    1627 BRANCHIF 1637
+    1629 ACC2 
+    1630 GETFIELD1 
+    1631 PUSHACC2 
+    1632 GETFIELD1 
+    1633 PUSHACC2 
+    1634 PUSHOFFSETCLOSURE0 
+    1635 APPTERM3 6
+    1637 RETURN 3
+    1639 ACC2 
+    1640 BRANCHIFNOT 1644
+    1642 BRANCH 1646
+    1644 RETURN 3
+    1646 GETGLOBAL "List.exists2"
+    1648 PUSHGETGLOBALFIELD Pervasives, 2
+    1651 APPTERM1 4
+    1653 RESTART 
+    1654 GRAB 1
+    1656 ACC1 
+    1657 BRANCHIFNOT 1672
+    1659 ACC0 
+    1660 PUSHACC2 
+    1661 GETFIELD0 
+    1662 C_CALL2 equal
+    1664 BRANCHIF 1672
+    1666 ACC1 
+    1667 GETFIELD1 
+    1668 PUSHACC1 
+    1669 PUSHOFFSETCLOSURE0 
+    1670 APPTERM2 4
+    1672 RETURN 2
+    1674 RESTART 
+    1675 GRAB 1
+    1677 ACC1 
+    1678 BRANCHIFNOT 1692
+    1680 ACC0 
+    1681 PUSHACC2 
+    1682 GETFIELD0 
+    1683 EQ 
+    1684 BRANCHIF 1692
+    1686 ACC1 
+    1687 GETFIELD1 
+    1688 PUSHACC1 
+    1689 PUSHOFFSETCLOSURE0 
+    1690 APPTERM2 4
+    1692 RETURN 2
+    1694 RESTART 
+    1695 GRAB 1
+    1697 ACC1 
+    1698 BRANCHIFNOT 1719
+    1700 ACC1 
+    1701 GETFIELD0 
+    1702 PUSHACC1 
+    1703 PUSHACC1 
+    1704 GETFIELD0 
+    1705 C_CALL2 equal
+    1707 BRANCHIFNOT 1713
+    1709 ACC0 
+    1710 GETFIELD1 
+    1711 RETURN 3
+    1713 ACC2 
+    1714 GETFIELD1 
+    1715 PUSHACC2 
+    1716 PUSHOFFSETCLOSURE0 
+    1717 APPTERM2 5
+    1719 GETGLOBAL Not_found
+    1721 MAKEBLOCK1 0
+    1723 RAISE 
+    1724 RESTART 
+    1725 GRAB 1
+    1727 ACC1 
+    1728 BRANCHIFNOT 1748
+    1730 ACC1 
+    1731 GETFIELD0 
+    1732 PUSHACC1 
+    1733 PUSHACC1 
+    1734 GETFIELD0 
+    1735 EQ 
+    1736 BRANCHIFNOT 1742
+    1738 ACC0 
+    1739 GETFIELD1 
+    1740 RETURN 3
+    1742 ACC2 
+    1743 GETFIELD1 
+    1744 PUSHACC2 
+    1745 PUSHOFFSETCLOSURE0 
+    1746 APPTERM2 5
+    1748 GETGLOBAL Not_found
+    1750 MAKEBLOCK1 0
+    1752 RAISE 
+    1753 RESTART 
+    1754 GRAB 1
+    1756 ACC1 
+    1757 BRANCHIFNOT 1773
+    1759 ACC0 
+    1760 PUSHACC2 
+    1761 GETFIELD0 
+    1762 GETFIELD0 
+    1763 C_CALL2 equal
+    1765 BRANCHIF 1773
+    1767 ACC1 
+    1768 GETFIELD1 
+    1769 PUSHACC1 
+    1770 PUSHOFFSETCLOSURE0 
+    1771 APPTERM2 4
+    1773 RETURN 2
+    1775 RESTART 
+    1776 GRAB 1
+    1778 ACC1 
+    1779 BRANCHIFNOT 1794
+    1781 ACC0 
+    1782 PUSHACC2 
+    1783 GETFIELD0 
+    1784 GETFIELD0 
+    1785 EQ 
+    1786 BRANCHIF 1794
+    1788 ACC1 
+    1789 GETFIELD1 
+    1790 PUSHACC1 
+    1791 PUSHOFFSETCLOSURE0 
+    1792 APPTERM2 4
+    1794 RETURN 2
+    1796 RESTART 
+    1797 GRAB 1
+    1799 ACC1 
+    1800 BRANCHIFNOT 1825
+    1802 ACC1 
+    1803 GETFIELD0 
+    1804 PUSHACC2 
+    1805 GETFIELD1 
+    1806 PUSHACC2 
+    1807 PUSHACC2 
+    1808 GETFIELD0 
+    1809 C_CALL2 equal
+    1811 BRANCHIFNOT 1816
+    1813 ACC0 
+    1814 RETURN 4
+    1816 ACC0 
+    1817 PUSHACC3 
+    1818 PUSHOFFSETCLOSURE0 
+    1819 APPLY2 
+    1820 PUSHACC2 
+    1821 MAKEBLOCK2 0
+    1823 POP 2
+    1825 RETURN 2
+    1827 RESTART 
+    1828 GRAB 1
+    1830 ACC1 
+    1831 BRANCHIFNOT 1855
+    1833 ACC1 
+    1834 GETFIELD0 
+    1835 PUSHACC2 
+    1836 GETFIELD1 
+    1837 PUSHACC2 
+    1838 PUSHACC2 
+    1839 GETFIELD0 
+    1840 EQ 
+    1841 BRANCHIFNOT 1846
+    1843 ACC0 
+    1844 RETURN 4
+    1846 ACC0 
+    1847 PUSHACC3 
+    1848 PUSHOFFSETCLOSURE0 
+    1849 APPLY2 
+    1850 PUSHACC2 
+    1851 MAKEBLOCK2 0
+    1853 POP 2
+    1855 RETURN 2
+    1857 RESTART 
+    1858 GRAB 1
+    1860 ACC1 
+    1861 BRANCHIFNOT 1879
+    1863 ACC1 
+    1864 GETFIELD0 
+    1865 PUSHACC0 
+    1866 PUSHACC2 
+    1867 APPLY1 
+    1868 BRANCHIFNOT 1873
+    1870 ACC0 
+    1871 RETURN 3
+    1873 ACC2 
+    1874 GETFIELD1 
+    1875 PUSHACC2 
+    1876 PUSHOFFSETCLOSURE0 
+    1877 APPTERM2 5
+    1879 GETGLOBAL Not_found
+    1881 MAKEBLOCK1 0
+    1883 RAISE 
+    1884 RESTART 
+    1885 GRAB 2
+    1887 ACC2 
+    1888 BRANCHIFNOT 1917
+    1890 ACC2 
+    1891 GETFIELD0 
+    1892 PUSHACC3 
+    1893 GETFIELD1 
+    1894 PUSHACC1 
+    1895 PUSHENVACC2 
+    1896 APPLY1 
+    1897 BRANCHIFNOT 1908
+    1899 ACC0 
+    1900 PUSHACC4 
+    1901 PUSHACC4 
+    1902 PUSHACC4 
+    1903 MAKEBLOCK2 0
+    1905 PUSHOFFSETCLOSURE0 
+    1906 APPTERM3 8
+    1908 ACC0 
+    1909 PUSHACC4 
+    1910 PUSHACC3 
+    1911 MAKEBLOCK2 0
+    1913 PUSHACC4 
+    1914 PUSHOFFSETCLOSURE0 
+    1915 APPTERM3 8
+    1917 ACC1 
+    1918 PUSHENVACC1 
+    1919 APPLY1 
+    1920 PUSHACC1 
+    1921 PUSHENVACC1 
+    1922 APPLY1 
+    1923 MAKEBLOCK2 0
+    1925 RETURN 3
+    1927 RESTART 
+    1928 GRAB 1
+    1930 ACC0 
+    1931 PUSHENVACC1 
+    1932 CLOSUREREC 2, 1885
+    1936 ACC2 
+    1937 PUSHCONST0 
+    1938 PUSHCONST0 
+    1939 PUSHACC3 
+    1940 APPTERM3 6
+    1942 ACC0 
+    1943 BRANCHIFNOT 1967
+    1945 ACC0 
+    1946 GETFIELD0 
+    1947 PUSHACC1 
+    1948 GETFIELD1 
+    1949 PUSHOFFSETCLOSURE0 
+    1950 APPLY1 
+    1951 PUSHACC0 
+    1952 GETFIELD1 
+    1953 PUSHACC2 
+    1954 GETFIELD1 
+    1955 MAKEBLOCK2 0
+    1957 PUSHACC1 
+    1958 GETFIELD0 
+    1959 PUSHACC3 
+    1960 GETFIELD0 
+    1961 MAKEBLOCK2 0
+    1963 MAKEBLOCK2 0
+    1965 RETURN 3
+    1967 GETGLOBAL <0>(0, 0)
+    1969 RETURN 1
+    1971 RESTART 
+    1972 GRAB 1
+    1974 ACC0 
+    1975 BRANCHIFNOT 1996
+    1977 ACC1 
+    1978 BRANCHIFNOT 2003
+    1980 ACC1 
+    1981 GETFIELD1 
+    1982 PUSHACC1 
+    1983 GETFIELD1 
+    1984 PUSHOFFSETCLOSURE0 
+    1985 APPLY2 
+    1986 PUSHACC2 
+    1987 GETFIELD0 
+    1988 PUSHACC2 
+    1989 GETFIELD0 
+    1990 MAKEBLOCK2 0
+    1992 MAKEBLOCK2 0
+    1994 RETURN 2
+    1996 ACC1 
+    1997 BRANCHIFNOT 2001
+    1999 BRANCH 2003
+    2001 RETURN 2
+    2003 GETGLOBAL "List.combine"
+    2005 PUSHGETGLOBALFIELD Pervasives, 2
+    2008 APPTERM1 3
+    2010 RESTART 
+    2011 GRAB 1
+    2013 ACC1 
+    2014 BRANCHIFNOT 2038
+    2016 ACC1 
+    2017 GETFIELD0 
+    2018 PUSHACC2 
+    2019 GETFIELD1 
+    2020 PUSHACC1 
+    2021 PUSHENVACC2 
+    2022 APPLY1 
+    2023 BRANCHIFNOT 2033
+    2025 ACC0 
+    2026 PUSHACC3 
+    2027 PUSHACC3 
+    2028 MAKEBLOCK2 0
+    2030 PUSHOFFSETCLOSURE0 
+    2031 APPTERM2 6
+    2033 ACC0 
+    2034 PUSHACC3 
+    2035 PUSHOFFSETCLOSURE0 
+    2036 APPTERM2 6
+    2038 ACC0 
+    2039 PUSHENVACC1 
+    2040 APPTERM1 3
+    2042 ACC0 
+    2043 PUSHENVACC1 
+    2044 CLOSUREREC 2, 2011
+    2048 CONST0 
+    2049 PUSHACC1 
+    2050 APPTERM1 3
+    2052 RESTART 
+    2053 GRAB 2
+    2055 ACC1 
+    2056 BRANCHIFNOT 2077
+    2058 ACC2 
+    2059 BRANCHIFNOT 2084
+    2061 ACC2 
+    2062 GETFIELD1 
+    2063 PUSHACC2 
+    2064 GETFIELD1 
+    2065 PUSHACC2 
+    2066 PUSHACC5 
+    2067 GETFIELD0 
+    2068 PUSHACC5 
+    2069 GETFIELD0 
+    2070 PUSHENVACC1 
+    2071 APPLY2 
+    2072 MAKEBLOCK2 0
+    2074 PUSHOFFSETCLOSURE0 
+    2075 APPTERM3 6
+    2077 ACC2 
+    2078 BRANCHIFNOT 2082
+    2080 BRANCH 2084
+    2082 RETURN 3
+    2084 GETGLOBAL "List.rev_map2"
+    2086 PUSHGETGLOBALFIELD Pervasives, 2
+    2089 APPTERM1 4
+    2091 RESTART 
+    2092 GRAB 2
+    2094 ACC0 
+    2095 CLOSUREREC 1, 2053
+    2099 ACC3 
+    2100 PUSHACC3 
+    2101 PUSHCONST0 
+    2102 PUSHACC3 
+    2103 APPTERM3 7
+    2105 RESTART 
+    2106 GRAB 1
+    2108 ACC1 
+    2109 BRANCHIFNOT 2123
+    2111 ACC1 
+    2112 GETFIELD1 
+    2113 PUSHACC1 
+    2114 PUSHACC3 
+    2115 GETFIELD0 
+    2116 PUSHENVACC1 
+    2117 APPLY1 
+    2118 MAKEBLOCK2 0
+    2120 PUSHOFFSETCLOSURE0 
+    2121 APPTERM2 4
+    2123 ACC0 
+    2124 RETURN 2
+    2126 RESTART 
+    2127 GRAB 1
+    2129 ACC0 
+    2130 CLOSUREREC 1, 2106
+    2134 ACC2 
+    2135 PUSHCONST0 
+    2136 PUSHACC2 
+    2137 APPTERM2 5
+    2139 CONST0 
+    2140 PUSHACC1 
+    2141 PUSHENVACC1 
+    2142 APPTERM2 3
+    2144 ACC0 
+    2145 BRANCHIFNOT 2151
+    2147 ACC0 
+    2148 GETFIELD1 
+    2149 RETURN 1
+    2151 GETGLOBAL "tl"
+    2153 PUSHGETGLOBALFIELD Pervasives, 3
+    2156 APPTERM1 2
+    2158 ACC0 
+    2159 BRANCHIFNOT 2165
+    2161 ACC0 
+    2162 GETFIELD0 
+    2163 RETURN 1
+    2165 GETGLOBAL "hd"
+    2167 PUSHGETGLOBALFIELD Pervasives, 3
+    2170 APPTERM1 2
+    2172 ACC0 
+    2173 PUSHCONST0 
+    2174 PUSHENVACC1 
+    2175 APPTERM2 3
+    2177 CLOSUREREC 0, 1200
+    2181 ACC0 
+    2182 CLOSURE 1, 2172
+    2185 PUSH 
+    2186 CLOSURE 0, 2158
+    2189 PUSH 
+    2190 CLOSURE 0, 2144
+    2193 PUSH 
+    2194 CLOSUREREC 0, 1217
+    2198 GETGLOBALFIELD Pervasives, 16
+    2201 PUSH 
+    2202 CLOSUREREC 0, 1259
+    2206 ACC0 
+    2207 CLOSURE 1, 2139
+    2210 PUSH 
+    2211 CLOSUREREC 0, 1277
+    2215 CLOSUREREC 0, 1294
+    2219 CLOSURE 0, 2127
+    2222 PUSH 
+    2223 CLOSUREREC 0, 1316
+    2227 CLOSUREREC 0, 1334
+    2231 CLOSUREREC 0, 1354
+    2235 CLOSUREREC 0, 1374
+    2239 CLOSURE 0, 2092
+    2242 PUSH 
+    2243 CLOSUREREC 0, 1415
+    2247 CLOSUREREC 0, 1452
+    2251 CLOSUREREC 0, 1490
+    2255 CLOSUREREC 0, 1530
+    2259 CLOSUREREC 0, 1553
+    2263 CLOSUREREC 0, 1573
+    2267 CLOSUREREC 0, 1613
+    2271 CLOSUREREC 0, 1654
+    2275 CLOSUREREC 0, 1675
+    2279 CLOSUREREC 0, 1695
+    2283 CLOSUREREC 0, 1725
+    2287 CLOSUREREC 0, 1754
+    2291 CLOSUREREC 0, 1776
+    2295 CLOSUREREC 0, 1797
+    2299 CLOSUREREC 0, 1828
+    2303 CLOSUREREC 0, 1858
+    2307 ACC 24
+    2309 CLOSURE 1, 2042
+    2312 PUSHACC 25
+    2314 CLOSUREREC 1, 1928
+    2318 CLOSUREREC 0, 1942
+    2322 CLOSUREREC 0, 1972
+    2326 ACC0 
+    2327 PUSHACC2 
+    2328 PUSHACC7 
+    2329 PUSHACC 9
+    2331 PUSHACC 11
+    2333 PUSHACC 13
+    2335 PUSHACC 15
+    2337 PUSHACC 17
+    2339 PUSHACC 10
+    2341 PUSHACC 12
+    2343 PUSHACC 13
+    2345 PUSHACC 15
+    2347 PUSHACC 23
+    2349 PUSHACC 25
+    2351 PUSHACC 27
+    2353 PUSHACC 29
+    2355 PUSHACC 31
+    2357 PUSHACC 33
+    2359 PUSHACC 35
+    2361 PUSHACC 37
+    2363 PUSHACC 40
+    2365 PUSHACC 42
+    2367 PUSHACC 41
+    2369 PUSHACC 45
+    2371 PUSHACC 47
+    2373 PUSHACC 50
+    2375 PUSHACC 52
+    2377 PUSHACC 51
+    2379 PUSHACC 55
+    2381 PUSHACC 56
+    2383 PUSHACC 59
+    2385 PUSHACC 61
+    2387 PUSHACC 60
+    2389 PUSHACC 64
+    2391 PUSHACC 66
+    2393 PUSHACC 68
+    2395 PUSHACC 70
+    2397 MAKEBLOCK 37, 0
+    2400 POP 36
+    2402 SETGLOBAL List
+    2404 BRANCH 3341
+    2406 RESTART 
+    2407 GRAB 2
+    2409 ACC2 
+    2410 PUSHACC2 
+    2411 VECTLENGTH 
+    2412 OFFSETINT -1
+    2414 PUSHCONST0 
+    2415 PUSH 
+    2416 BRANCH 2433
+    2418 CHECK_SIGNALS 
+    2419 ACC2 
+    2420 PUSHACC2 
+    2421 PUSHACC6 
+    2422 C_CALL2 array_unsafe_get
+    2424 PUSHACC5 
+    2425 APPLY2 
+    2426 ASSIGN 2
+    2428 ACC1 
+    2429 OFFSETINT -1
+    2431 ASSIGN 1
+    2433 ACC0 
+    2434 PUSHACC2 
+    2435 GEINT 
+    2436 BRANCHIF 2418
+    2438 CONST0 
+    2439 POP 2
+    2441 ACC0 
+    2442 RETURN 4
+    2444 RESTART 
+    2445 GRAB 2
+    2447 ACC1 
+    2448 PUSHCONST0 
+    2449 PUSHACC4 
+    2450 VECTLENGTH 
+    2451 OFFSETINT -1
+    2453 PUSH 
+    2454 BRANCH 2471
+    2456 CHECK_SIGNALS 
+    2457 ACC1 
+    2458 PUSHACC6 
+    2459 C_CALL2 array_unsafe_get
+    2461 PUSHACC3 
+    2462 PUSHACC5 
+    2463 APPLY2 
+    2464 ASSIGN 2
+    2466 ACC1 
+    2467 OFFSETINT 1
+    2469 ASSIGN 1
+    2471 ACC0 
+    2472 PUSHACC2 
+    2473 LEINT 
+    2474 BRANCHIF 2456
+    2476 CONST0 
+    2477 POP 2
+    2479 ACC0 
+    2480 RETURN 4
+    2482 RESTART 
+    2483 GRAB 1
+    2485 ACC1 
+    2486 BRANCHIFNOT 2502
+    2488 ACC1 
+    2489 GETFIELD0 
+    2490 PUSHACC1 
+    2491 PUSHENVACC1 
+    2492 C_CALL3 array_unsafe_set
+    2494 ACC1 
+    2495 GETFIELD1 
+    2496 PUSHACC1 
+    2497 OFFSETINT 1
+    2499 PUSHOFFSETCLOSURE0 
+    2500 APPTERM2 4
+    2502 ENVACC1 
+    2503 RETURN 2
+    2505 ACC0 
+    2506 BRANCHIFNOT 2531
+    2508 ACC0 
+    2509 GETFIELD1 
+    2510 PUSHACC1 
+    2511 GETFIELD0 
+    2512 PUSHACC1 
+    2513 PUSHGETGLOBALFIELD List, 0
+    2516 APPLY1 
+    2517 OFFSETINT 1
+    2519 C_CALL2 make_vect
+    2521 PUSHACC0 
+    2522 CLOSUREREC 1, 2483
+    2526 ACC2 
+    2527 PUSHCONST1 
+    2528 PUSHACC2 
+    2529 APPTERM2 6
+    2531 ATOM0 
+    2532 RETURN 1
+    2534 RESTART 
+    2535 GRAB 1
+    2537 CONST0 
+    2538 PUSHACC1 
+    2539 LTINT 
+    2540 BRANCHIFNOT 2545
+    2542 ACC1 
+    2543 RETURN 2
+    2545 ACC1 
+    2546 PUSHACC1 
+    2547 PUSHENVACC1 
+    2548 C_CALL2 array_unsafe_get
+    2550 MAKEBLOCK2 0
+    2552 PUSHACC1 
+    2553 OFFSETINT -1
+    2555 PUSHOFFSETCLOSURE0 
+    2556 APPTERM2 4
+    2558 ACC0 
+    2559 CLOSUREREC 1, 2535
+    2563 CONST0 
+    2564 PUSHACC2 
+    2565 VECTLENGTH 
+    2566 OFFSETINT -1
+    2568 PUSHACC2 
+    2569 APPTERM2 4
+    2571 RESTART 
+    2572 GRAB 1
+    2574 ACC1 
+    2575 VECTLENGTH 
+    2576 PUSHCONST0 
+    2577 PUSHACC1 
+    2578 EQ 
+    2579 BRANCHIFNOT 2584
+    2581 ATOM0 
+    2582 RETURN 3
+    2584 CONST0 
+    2585 PUSHACC3 
+    2586 C_CALL2 array_unsafe_get
+    2588 PUSHCONST0 
+    2589 PUSHACC3 
+    2590 APPLY2 
+    2591 PUSHACC1 
+    2592 C_CALL2 make_vect
+    2594 PUSHCONST1 
+    2595 PUSHACC2 
+    2596 OFFSETINT -1
+    2598 PUSH 
+    2599 BRANCH 2618
+    2601 CHECK_SIGNALS 
+    2602 ACC1 
+    2603 PUSHACC6 
+    2604 C_CALL2 array_unsafe_get
+    2606 PUSHACC2 
+    2607 PUSHACC6 
+    2608 APPLY2 
+    2609 PUSHACC2 
+    2610 PUSHACC4 
+    2611 C_CALL3 array_unsafe_set
+    2613 ACC1 
+    2614 OFFSETINT 1
+    2616 ASSIGN 1
+    2618 ACC0 
+    2619 PUSHACC2 
+    2620 LEINT 
+    2621 BRANCHIF 2601
+    2623 CONST0 
+    2624 POP 2
+    2626 ACC0 
+    2627 RETURN 4
+    2629 RESTART 
+    2630 GRAB 1
+    2632 CONST0 
+    2633 PUSHACC2 
+    2634 VECTLENGTH 
+    2635 OFFSETINT -1
+    2637 PUSH 
+    2638 BRANCH 2653
+    2640 CHECK_SIGNALS 
+    2641 ACC1 
+    2642 PUSHACC4 
+    2643 C_CALL2 array_unsafe_get
+    2645 PUSHACC2 
+    2646 PUSHACC4 
+    2647 APPLY2 
+    2648 ACC1 
+    2649 OFFSETINT 1
+    2651 ASSIGN 1
+    2653 ACC0 
+    2654 PUSHACC2 
+    2655 LEINT 
+    2656 BRANCHIF 2640
+    2658 CONST0 
+    2659 RETURN 4
+    2661 RESTART 
+    2662 GRAB 1
+    2664 ACC1 
+    2665 VECTLENGTH 
+    2666 PUSHCONST0 
+    2667 PUSHACC1 
+    2668 EQ 
+    2669 BRANCHIFNOT 2674
+    2671 ATOM0 
+    2672 RETURN 3
+    2674 CONST0 
+    2675 PUSHACC3 
+    2676 C_CALL2 array_unsafe_get
+    2678 PUSHACC2 
+    2679 APPLY1 
+    2680 PUSHACC1 
+    2681 C_CALL2 make_vect
+    2683 PUSHCONST1 
+    2684 PUSHACC2 
+    2685 OFFSETINT -1
+    2687 PUSH 
+    2688 BRANCH 2706
+    2690 CHECK_SIGNALS 
+    2691 ACC1 
+    2692 PUSHACC6 
+    2693 C_CALL2 array_unsafe_get
+    2695 PUSHACC5 
+    2696 APPLY1 
+    2697 PUSHACC2 
+    2698 PUSHACC4 
+    2699 C_CALL3 array_unsafe_set
+    2701 ACC1 
+    2702 OFFSETINT 1
+    2704 ASSIGN 1
+    2706 ACC0 
+    2707 PUSHACC2 
+    2708 LEINT 
+    2709 BRANCHIF 2690
+    2711 CONST0 
+    2712 POP 2
+    2714 ACC0 
+    2715 RETURN 4
+    2717 RESTART 
+    2718 GRAB 1
+    2720 CONST0 
+    2721 PUSHACC2 
+    2722 VECTLENGTH 
+    2723 OFFSETINT -1
+    2725 PUSH 
+    2726 BRANCH 2740
+    2728 CHECK_SIGNALS 
+    2729 ACC1 
+    2730 PUSHACC4 
+    2731 C_CALL2 array_unsafe_get
+    2733 PUSHACC3 
+    2734 APPLY1 
+    2735 ACC1 
+    2736 OFFSETINT 1
+    2738 ASSIGN 1
+    2740 ACC0 
+    2741 PUSHACC2 
+    2742 LEINT 
+    2743 BRANCHIF 2728
+    2745 CONST0 
+    2746 RETURN 4
+    2748 RESTART 
+    2749 GRAB 4
+    2751 CONST0 
+    2752 PUSHACC5 
+    2753 LTINT 
+    2754 BRANCHIF 2782
+    2756 CONST0 
+    2757 PUSHACC2 
+    2758 LTINT 
+    2759 BRANCHIF 2782
+    2761 ACC0 
+    2762 VECTLENGTH 
+    2763 PUSHACC5 
+    2764 PUSHACC3 
+    2765 ADDINT 
+    2766 GTINT 
+    2767 BRANCHIF 2782
+    2769 CONST0 
+    2770 PUSHACC4 
+    2771 LTINT 
+    2772 BRANCHIF 2782
+    2774 ACC2 
+    2775 VECTLENGTH 
+    2776 PUSHACC5 
+    2777 PUSHACC5 
+    2778 ADDINT 
+    2779 GTINT 
+    2780 BRANCHIFNOT 2789
+    2782 GETGLOBAL "Array.blit"
+    2784 PUSHGETGLOBALFIELD Pervasives, 2
+    2787 APPTERM1 6
+    2789 ACC3 
+    2790 PUSHACC2 
+    2791 LTINT 
+    2792 BRANCHIFNOT 2827
+    2794 ACC4 
+    2795 OFFSETINT -1
+    2797 PUSHCONST0 
+    2798 PUSH 
+    2799 BRANCH 2819
+    2801 CHECK_SIGNALS 
+    2802 ACC1 
+    2803 PUSHACC4 
+    2804 ADDINT 
+    2805 PUSHACC3 
+    2806 C_CALL2 array_unsafe_get
+    2808 PUSHACC2 
+    2809 PUSHACC7 
+    2810 ADDINT 
+    2811 PUSHACC6 
+    2812 C_CALL3 array_unsafe_set
+    2814 ACC1 
+    2815 OFFSETINT -1
+    2817 ASSIGN 1
+    2819 ACC0 
+    2820 PUSHACC2 
+    2821 GEINT 
+    2822 BRANCHIF 2801
+    2824 CONST0 
+    2825 RETURN 7
+    2827 CONST0 
+    2828 PUSHACC5 
+    2829 OFFSETINT -1
+    2831 PUSH 
+    2832 BRANCH 2852
+    2834 CHECK_SIGNALS 
+    2835 ACC1 
+    2836 PUSHACC4 
+    2837 ADDINT 
+    2838 PUSHACC3 
+    2839 C_CALL2 array_unsafe_get
+    2841 PUSHACC2 
+    2842 PUSHACC7 
+    2843 ADDINT 
+    2844 PUSHACC6 
+    2845 C_CALL3 array_unsafe_set
+    2847 ACC1 
+    2848 OFFSETINT 1
+    2850 ASSIGN 1
+    2852 ACC0 
+    2853 PUSHACC2 
+    2854 LEINT 
+    2855 BRANCHIF 2834
+    2857 CONST0 
+    2858 RETURN 7
+    2860 RESTART 
+    2861 GRAB 3
+    2863 CONST0 
+    2864 PUSHACC2 
+    2865 LTINT 
+    2866 BRANCHIF 2881
+    2868 CONST0 
+    2869 PUSHACC3 
+    2870 LTINT 
+    2871 BRANCHIF 2881
+    2873 ACC0 
+    2874 VECTLENGTH 
+    2875 PUSHACC3 
+    2876 PUSHACC3 
+    2877 ADDINT 
+    2878 GTINT 
+    2879 BRANCHIFNOT 2888
+    2881 GETGLOBAL "Array.fill"
+    2883 PUSHGETGLOBALFIELD Pervasives, 2
+    2886 APPTERM1 5
+    2888 ACC1 
+    2889 PUSHACC3 
+    2890 PUSHACC3 
+    2891 ADDINT 
+    2892 OFFSETINT -1
+    2894 PUSH 
+    2895 BRANCH 2908
+    2897 CHECK_SIGNALS 
+    2898 ACC5 
+    2899 PUSHACC2 
+    2900 PUSHACC4 
+    2901 C_CALL3 array_unsafe_set
+    2903 ACC1 
+    2904 OFFSETINT 1
+    2906 ASSIGN 1
+    2908 ACC0 
+    2909 PUSHACC2 
+    2910 LEINT 
+    2911 BRANCHIF 2897
+    2913 CONST0 
+    2914 RETURN 6
+    2916 RESTART 
+    2917 GRAB 2
+    2919 CONST0 
+    2920 PUSHACC2 
+    2921 LTINT 
+    2922 BRANCHIF 2937
+    2924 CONST0 
+    2925 PUSHACC3 
+    2926 LTINT 
+    2927 BRANCHIF 2937
+    2929 ACC0 
+    2930 VECTLENGTH 
+    2931 PUSHACC3 
+    2932 PUSHACC3 
+    2933 ADDINT 
+    2934 GTINT 
+    2935 BRANCHIFNOT 2944
+    2937 GETGLOBAL "Array.sub"
+    2939 PUSHGETGLOBALFIELD Pervasives, 2
+    2942 APPTERM1 4
+    2944 CONST0 
+    2945 PUSHACC3 
+    2946 EQ 
+    2947 BRANCHIFNOT 2952
+    2949 ATOM0 
+    2950 RETURN 3
+    2952 ACC1 
+    2953 PUSHACC1 
+    2954 C_CALL2 array_unsafe_get
+    2956 PUSHACC3 
+    2957 C_CALL2 make_vect
+    2959 PUSHCONST1 
+    2960 PUSHACC4 
+    2961 OFFSETINT -1
+    2963 PUSH 
+    2964 BRANCH 2982
+    2966 CHECK_SIGNALS 
+    2967 ACC1 
+    2968 PUSHACC5 
+    2969 ADDINT 
+    2970 PUSHACC4 
+    2971 C_CALL2 array_unsafe_get
+    2973 PUSHACC2 
+    2974 PUSHACC4 
+    2975 C_CALL3 array_unsafe_set
+    2977 ACC1 
+    2978 OFFSETINT 1
+    2980 ASSIGN 1
+    2982 ACC0 
+    2983 PUSHACC2 
+    2984 LEINT 
+    2985 BRANCHIF 2966
+    2987 CONST0 
+    2988 POP 2
+    2990 ACC0 
+    2991 RETURN 4
+    2993 ACC0 
+    2994 BRANCHIFNOT 3017
+    2996 ACC0 
+    2997 GETFIELD0 
+    2998 PUSHCONST0 
+    2999 PUSHACC1 
+    3000 VECTLENGTH 
+    3001 GTINT 
+    3002 BRANCHIFNOT 3012
+    3004 ENVACC2 
+    3005 PUSHCONST0 
+    3006 PUSHACC2 
+    3007 C_CALL2 array_unsafe_get
+    3009 PUSHENVACC1 
+    3010 APPTERM2 4
+    3012 ACC1 
+    3013 GETFIELD1 
+    3014 PUSHOFFSETCLOSURE0 
+    3015 APPTERM1 3
+    3017 ATOM0 
+    3018 RETURN 1
+    3020 ACC0 
+    3021 PUSHENVACC1 
+    3022 CLOSUREREC 2, 2993
+    3026 ACC1 
+    3027 PUSHACC1 
+    3028 APPTERM1 3
+    3030 CONST0 
+    3031 PUSHACC1 
+    3032 VECTLENGTH 
+    3033 OFFSETINT -1
+    3035 PUSH 
+    3036 BRANCH 3056
+    3038 CHECK_SIGNALS 
+    3039 ACC1 
+    3040 PUSHACC3 
+    3041 C_CALL2 array_unsafe_get
+    3043 PUSHENVACC2 
+    3044 GETFIELD0 
+    3045 PUSHENVACC1 
+    3046 C_CALL3 array_unsafe_set
+    3048 ENVACC2 
+    3049 OFFSETREF 1
+    3051 ACC1 
+    3052 OFFSETINT 1
+    3054 ASSIGN 1
+    3056 ACC0 
+    3057 PUSHACC2 
+    3058 LEINT 
+    3059 BRANCHIF 3038
+    3061 CONST0 
+    3062 RETURN 3
+    3064 RESTART 
+    3065 GRAB 1
+    3067 ACC1 
+    3068 VECTLENGTH 
+    3069 PUSHACC1 
+    3070 ADDINT 
+    3071 RETURN 2
+    3073 RESTART 
+    3074 GRAB 1
+    3076 ACC1 
+    3077 PUSHCONST0 
+    3078 PUSH 
+    3079 CLOSURE 0, 3065
+    3082 PUSHGETGLOBALFIELD List, 12
+    3085 APPLY3 
+    3086 PUSHACC1 
+    3087 PUSHACC1 
+    3088 C_CALL2 make_vect
+    3090 PUSHCONST0 
+    3091 MAKEBLOCK1 0
+    3093 PUSHACC4 
+    3094 PUSHACC1 
+    3095 PUSHACC3 
+    3096 CLOSURE 2, 3030
+    3099 PUSHGETGLOBALFIELD List, 9
+    3102 APPLY2 
+    3103 ACC1 
+    3104 RETURN 5
+    3106 RESTART 
+    3107 GRAB 1
+    3109 ACC0 
+    3110 VECTLENGTH 
+    3111 PUSHACC2 
+    3112 VECTLENGTH 
+    3113 PUSHCONST0 
+    3114 PUSHACC2 
+    3115 EQ 
+    3116 BRANCHIFNOT 3126
+    3118 CONST0 
+    3119 PUSHACC1 
+    3120 EQ 
+    3121 BRANCHIFNOT 3126
+    3123 ATOM0 
+    3124 RETURN 4
+    3126 CONST0 
+    3127 PUSHCONST0 
+    3128 PUSHACC3 
+    3129 GTINT 
+    3130 BRANCHIFNOT 3135
+    3132 ACC3 
+    3133 BRANCH 3136
+    3135 ACC4 
+    3136 C_CALL2 array_unsafe_get
+    3138 PUSHACC1 
+    3139 PUSHACC3 
+    3140 ADDINT 
+    3141 C_CALL2 make_vect
+    3143 PUSHCONST0 
+    3144 PUSHACC3 
+    3145 OFFSETINT -1
+    3147 PUSH 
+    3148 BRANCH 3164
+    3150 CHECK_SIGNALS 
+    3151 ACC1 
+    3152 PUSHACC6 
+    3153 C_CALL2 array_unsafe_get
+    3155 PUSHACC2 
+    3156 PUSHACC4 
+    3157 C_CALL3 array_unsafe_set
+    3159 ACC1 
+    3160 OFFSETINT 1
+    3162 ASSIGN 1
+    3164 ACC0 
+    3165 PUSHACC2 
+    3166 LEINT 
+    3167 BRANCHIF 3150
+    3169 CONST0 
+    3170 POP 2
+    3172 CONST0 
+    3173 PUSHACC2 
+    3174 OFFSETINT -1
+    3176 PUSH 
+    3177 BRANCH 3195
+    3179 CHECK_SIGNALS 
+    3180 ACC1 
+    3181 PUSHACC7 
+    3182 C_CALL2 array_unsafe_get
+    3184 PUSHACC5 
+    3185 PUSHACC3 
+    3186 ADDINT 
+    3187 PUSHACC4 
+    3188 C_CALL3 array_unsafe_set
+    3190 ACC1 
+    3191 OFFSETINT 1
+    3193 ASSIGN 1
+    3195 ACC0 
+    3196 PUSHACC2 
+    3197 LEINT 
+    3198 BRANCHIF 3179
+    3200 CONST0 
+    3201 POP 2
+    3203 ACC0 
+    3204 RETURN 5
+    3206 ACC0 
+    3207 VECTLENGTH 
+    3208 PUSHCONST0 
+    3209 PUSHACC1 
+    3210 EQ 
+    3211 BRANCHIFNOT 3216
+    3213 ATOM0 
+    3214 RETURN 2
+    3216 CONST0 
+    3217 PUSHACC2 
+    3218 C_CALL2 array_unsafe_get
+    3220 PUSHACC1 
+    3221 C_CALL2 make_vect
+    3223 PUSHCONST1 
+    3224 PUSHACC2 
+    3225 OFFSETINT -1
+    3227 PUSH 
+    3228 BRANCH 3244
+    3230 CHECK_SIGNALS 
+    3231 ACC1 
+    3232 PUSHACC5 
+    3233 C_CALL2 array_unsafe_get
+    3235 PUSHACC2 
+    3236 PUSHACC4 
+    3237 C_CALL3 array_unsafe_set
+    3239 ACC1 
+    3240 OFFSETINT 1
+    3242 ASSIGN 1
+    3244 ACC0 
+    3245 PUSHACC2 
+    3246 LEINT 
+    3247 BRANCHIF 3230
+    3249 CONST0 
+    3250 POP 2
+    3252 ACC0 
+    3253 RETURN 3
+    3255 RESTART 
+    3256 GRAB 2
+    3258 ATOM0 
+    3259 PUSHACC1 
+    3260 C_CALL2 make_vect
+    3262 PUSHCONST0 
+    3263 PUSHACC2 
+    3264 OFFSETINT -1
+    3266 PUSH 
+    3267 BRANCH 3282
+    3269 CHECK_SIGNALS 
+    3270 ACC5 
+    3271 PUSHACC5 
+    3272 C_CALL2 make_vect
+    3274 PUSHACC2 
+    3275 PUSHACC4 
+    3276 SETVECTITEM 
+    3277 ACC1 
+    3278 OFFSETINT 1
+    3280 ASSIGN 1
+    3282 ACC0 
+    3283 PUSHACC2 
+    3284 LEINT 
+    3285 BRANCHIF 3269
+    3287 CONST0 
+    3288 POP 2
+    3290 ACC0 
+    3291 RETURN 4
+    3293 RESTART 
+    3294 GRAB 1
+    3296 CONST0 
+    3297 PUSHACC1 
+    3298 EQ 
+    3299 BRANCHIFNOT 3304
+    3301 ATOM0 
+    3302 RETURN 2
+    3304 CONST0 
+    3305 PUSHACC2 
+    3306 APPLY1 
+    3307 PUSHACC1 
+    3308 C_CALL2 make_vect
+    3310 PUSHCONST1 
+    3311 PUSHACC2 
+    3312 OFFSETINT -1
+    3314 PUSH 
+    3315 BRANCH 3330
+    3317 CHECK_SIGNALS 
+    3318 ACC1 
+    3319 PUSHACC5 
+    3320 APPLY1 
+    3321 PUSHACC2 
+    3322 PUSHACC4 
+    3323 C_CALL3 array_unsafe_set
+    3325 ACC1 
+    3326 OFFSETINT 1
+    3328 ASSIGN 1
+    3330 ACC0 
+    3331 PUSHACC2 
+    3332 LEINT 
+    3333 BRANCHIF 3317
+    3335 CONST0 
+    3336 POP 2
+    3338 ACC0 
+    3339 RETURN 3
+    3341 CLOSURE 0, 3294
+    3344 PUSH 
+    3345 CLOSURE 0, 3256
+    3348 PUSH 
+    3349 CLOSURE 0, 3206
+    3352 PUSH 
+    3353 CLOSURE 0, 3107
+    3356 PUSH 
+    3357 CLOSURE 0, 3074
+    3360 PUSHACC0 
+    3361 CLOSURE 1, 3020
+    3364 PUSH 
+    3365 CLOSURE 0, 2917
+    3368 PUSH 
+    3369 CLOSURE 0, 2861
+    3372 PUSH 
+    3373 CLOSURE 0, 2749
+    3376 PUSH 
+    3377 CLOSURE 0, 2718
+    3380 PUSH 
+    3381 CLOSURE 0, 2662
+    3384 PUSH 
+    3385 CLOSURE 0, 2630
+    3388 PUSH 
+    3389 CLOSURE 0, 2572
+    3392 PUSH 
+    3393 CLOSURE 0, 2558
+    3396 PUSH 
+    3397 CLOSURE 0, 2505
+    3400 PUSH 
+    3401 CLOSURE 0, 2445
+    3404 PUSH 
+    3405 CLOSURE 0, 2407
+    3408 PUSHACC0 
+    3409 PUSHACC2 
+    3410 PUSHACC6 
+    3411 PUSHACC 8
+    3413 PUSHACC 10
+    3415 PUSHACC 12
+    3417 PUSHACC 8
+    3419 PUSHACC 10
+    3421 PUSHACC 16
+    3423 PUSHACC 18
+    3425 PUSHACC 24
+    3427 PUSHACC 21
+    3429 PUSHACC 23
+    3431 PUSHACC 26
+    3433 PUSHACC 29
+    3435 PUSHACC 30
+    3437 PUSHACC 32
+    3439 MAKEBLOCK 17, 0
+    3442 POP 17
+    3444 SETGLOBAL Array
+    3446 BRANCH 3480
+    3448 ENVACC1 
+    3449 MAKEBLOCK1 0
+    3451 RAISE 
+    3452 ACC0 
+    3453 BRANCHIFNOT 3465
+    3455 ENVACC3 
+    3456 CLOSURE 1, 3448
+    3459 MAKEBLOCK1 0
+    3461 PUSHENVACC2 
+    3462 PUSHENVACC1 
+    3463 APPTERM2 3
+    3465 CONST0 
+    3466 PUSHENVACC2 
+    3467 PUSHENVACC1 
+    3468 APPTERM2 3
+    3470 RESTART 
+    3471 GRAB 1
+    3473 ACC1 
+    3474 PUSHACC1 
+    3475 C_CALL2 install_signal_handler
+    3477 CONST0 
+    3478 RETURN 2
+    3480 CONST0 
+    3481 C_CALL1 sys_get_argv
+    3483 PUSHCONST0 
+    3484 C_CALL1 sys_get_config
+    3486 PUSHACC0 
+    3487 GETFIELD1 
+    3488 PUSHACC0 
+    3489 OFFSETINT -10
+    3491 PUSHCONST1 
+    3492 LSLINT 
+    3493 OFFSETINT -1
+    3495 PUSHACC0 
+    3496 PUSHCONSTINT 8
+    3498 PUSHACC3 
+    3499 DIVINT 
+    3500 MULINT 
+    3501 OFFSETINT -1
+    3503 PUSHCONST0 
+    3504 MAKEBLOCK1 0
+    3506 PUSH 
+    3507 CLOSURE 0, 3471
+    3510 PUSHCONSTINT -1
+    3512 PUSHCONSTINT -2
+    3514 PUSHCONSTINT -3
+    3516 PUSHCONSTINT -4
+    3518 PUSHCONSTINT -5
+    3520 PUSHCONSTINT -6
+    3522 PUSHCONSTINT -7
+    3524 PUSHCONSTINT -8
+    3526 PUSHCONSTINT -9
+    3528 PUSHCONSTINT -10
+    3530 PUSHCONSTINT -11
+    3532 PUSHCONSTINT -12
+    3534 PUSHCONSTINT -13
+    3536 PUSHCONSTINT -14
+    3538 PUSHCONSTINT -15
+    3540 PUSHCONSTINT -16
+    3542 PUSHCONSTINT -17
+    3544 PUSHCONSTINT -18
+    3546 PUSHCONSTINT -19
+    3548 PUSHCONSTINT -20
+    3550 PUSHCONSTINT -21
+    3552 PUSHGETGLOBAL "Sys.Break"
+    3554 MAKEBLOCK1 0
+    3556 PUSHACC0 
+    3557 PUSHACC 17
+    3559 PUSHACC 24
+    3561 CLOSURE 3, 3452
+    3564 PUSHACC0 
+    3565 PUSHACC2 
+    3566 PUSHACC4 
+    3567 PUSHACC6 
+    3568 PUSHACC 8
+    3570 PUSHACC 10
+    3572 PUSHACC 12
+    3574 PUSHACC 14
+    3576 PUSHACC 16
+    3578 PUSHACC 18
+    3580 PUSHACC 20
+    3582 PUSHACC 22
+    3584 PUSHACC 24
+    3586 PUSHACC 26
+    3588 PUSHACC 28
+    3590 PUSHACC 30
+    3592 PUSHACC 32
+    3594 PUSHACC 34
+    3596 PUSHACC 36
+    3598 PUSHACC 38
+    3600 PUSHACC 40
+    3602 PUSHACC 42
+    3604 PUSHACC 44
+    3606 PUSHACC 46
+    3608 PUSHACC 50
+    3610 PUSHACC 50
+    3612 PUSHACC 53
+    3614 PUSHACC 55
+    3616 GETFIELD0 
+    3617 PUSHACC 52
+    3619 PUSHACC 58
+    3621 MAKEBLOCK 30, 0
+    3624 POP 30
+    3626 SETGLOBAL Sys
+    3628 BRANCH 4510
+    3630 RESTART 
+    3631 GRAB 1
+    3633 CONST0 
+    3634 PUSHACC1 
+    3635 LTINT 
+    3636 BRANCHIFNOT 3641
+    3638 CONST1 
+    3639 RETURN 2
+    3641 ACC1 
+    3642 BRANCHIFNOT 3652
+    3644 ACC1 
+    3645 GETFIELD2 
+    3646 PUSHACC1 
+    3647 OFFSETINT -1
+    3649 PUSHOFFSETCLOSURE0 
+    3650 APPTERM2 4
+    3652 RETURN 2
+    3654 ACC0 
+    3655 BRANCHIFNOT 3670
+    3657 ENVACC2 
+    3658 PUSHACC1 
+    3659 GETFIELD0 
+    3660 PUSHENVACC1 
+    3661 GETFIELD0 
+    3662 APPLY2 
+    3663 BRANCHIF 3670
+    3665 ACC0 
+    3666 GETFIELD2 
+    3667 PUSHOFFSETCLOSURE0 
+    3668 APPTERM1 2
+    3670 RETURN 1
+    3672 RESTART 
+    3673 GRAB 1
+    3675 ACC1 
+    3676 PUSHENVACC1 
+    3677 CLOSUREREC 2, 3654
+    3681 ACC1 
+    3682 GETFIELD1 
+    3683 VECTLENGTH 
+    3684 PUSHACC3 
+    3685 PUSHENVACC1 
+    3686 GETFIELD1 
+    3687 APPLY1 
+    3688 MODINT 
+    3689 PUSHACC2 
+    3690 GETFIELD1 
+    3691 C_CALL2 array_get_addr
+    3693 PUSHACC1 
+    3694 APPTERM1 4
+    3696 ACC0 
+    3697 BRANCHIFNOT 3722
+    3699 ACC0 
+    3700 GETFIELD2 
+    3701 PUSHENVACC2 
+    3702 PUSHACC2 
+    3703 GETFIELD0 
+    3704 PUSHENVACC1 
+    3705 GETFIELD0 
+    3706 APPLY2 
+    3707 BRANCHIFNOT 3718
+    3709 ACC0 
+    3710 PUSHOFFSETCLOSURE0 
+    3711 APPLY1 
+    3712 PUSHACC2 
+    3713 GETFIELD1 
+    3714 MAKEBLOCK2 0
+    3716 RETURN 2
+    3718 ACC0 
+    3719 PUSHOFFSETCLOSURE0 
+    3720 APPTERM1 3
+    3722 RETURN 1
+    3724 RESTART 
+    3725 GRAB 1
+    3727 ACC1 
+    3728 PUSHENVACC1 
+    3729 CLOSUREREC 2, 3696
+    3733 ACC1 
+    3734 GETFIELD1 
+    3735 VECTLENGTH 
+    3736 PUSHACC3 
+    3737 PUSHENVACC1 
+    3738 GETFIELD1 
+    3739 APPLY1 
+    3740 MODINT 
+    3741 PUSHACC2 
+    3742 GETFIELD1 
+    3743 C_CALL2 array_get_addr
+    3745 PUSHACC1 
+    3746 APPTERM1 4
+    3748 ACC0 
+    3749 BRANCHIFNOT 3768
+    3751 ACC0 
+    3752 GETFIELD0 
+    3753 PUSHENVACC2 
+    3754 PUSHENVACC1 
+    3755 GETFIELD0 
+    3756 APPLY2 
+    3757 BRANCHIFNOT 3763
+    3759 ACC0 
+    3760 GETFIELD1 
+    3761 RETURN 1
+    3763 ACC0 
+    3764 GETFIELD2 
+    3765 PUSHOFFSETCLOSURE0 
+    3766 APPTERM1 2
+    3768 GETGLOBAL Not_found
+    3770 MAKEBLOCK1 0
+    3772 RAISE 
+    3773 RESTART 
+    3774 GRAB 1
+    3776 ACC0 
+    3777 GETFIELD1 
+    3778 VECTLENGTH 
+    3779 PUSHACC2 
+    3780 PUSHENVACC1 
+    3781 GETFIELD1 
+    3782 APPLY1 
+    3783 MODINT 
+    3784 PUSHACC1 
+    3785 GETFIELD1 
+    3786 C_CALL2 array_get_addr
+    3788 PUSHACC0 
+    3789 BRANCHIFNOT 3858
+    3791 ACC0 
+    3792 GETFIELD2 
+    3793 PUSHACC1 
+    3794 GETFIELD0 
+    3795 PUSHACC4 
+    3796 PUSHENVACC1 
+    3797 GETFIELD0 
+    3798 APPLY2 
+    3799 BRANCHIFNOT 3805
+    3801 ACC1 
+    3802 GETFIELD1 
+    3803 RETURN 4
+    3805 ACC0 
+    3806 BRANCHIFNOT 3853
+    3808 ACC0 
+    3809 GETFIELD2 
+    3810 PUSHACC1 
+    3811 GETFIELD0 
+    3812 PUSHACC5 
+    3813 PUSHENVACC1 
+    3814 GETFIELD0 
+    3815 APPLY2 
+    3816 BRANCHIFNOT 3822
+    3818 ACC1 
+    3819 GETFIELD1 
+    3820 RETURN 5
+    3822 ACC0 
+    3823 BRANCHIFNOT 3848
+    3825 ACC0 
+    3826 GETFIELD0 
+    3827 PUSHACC5 
+    3828 PUSHENVACC1 
+    3829 GETFIELD0 
+    3830 APPLY2 
+    3831 BRANCHIFNOT 3837
+    3833 ACC0 
+    3834 GETFIELD1 
+    3835 RETURN 5
+    3837 ACC4 
+    3838 PUSHENVACC1 
+    3839 CLOSUREREC 2, 3748
+    3843 ACC1 
+    3844 GETFIELD2 
+    3845 PUSHACC1 
+    3846 APPTERM1 7
+    3848 GETGLOBAL Not_found
+    3850 MAKEBLOCK1 0
+    3852 RAISE 
+    3853 GETGLOBAL Not_found
+    3855 MAKEBLOCK1 0
+    3857 RAISE 
+    3858 GETGLOBAL Not_found
+    3860 MAKEBLOCK1 0
+    3862 RAISE 
+    3863 ACC0 
+    3864 BRANCHIFNOT 3890
+    3866 ACC0 
+    3867 GETFIELD0 
+    3868 PUSHACC1 
+    3869 GETFIELD2 
+    3870 PUSHENVACC2 
+    3871 PUSHACC2 
+    3872 PUSHENVACC1 
+    3873 GETFIELD0 
+    3874 APPLY2 
+    3875 BRANCHIFNOT 3880
+    3877 ACC0 
+    3878 RETURN 3
+    3880 ACC0 
+    3881 PUSHOFFSETCLOSURE0 
+    3882 APPLY1 
+    3883 PUSHACC3 
+    3884 GETFIELD1 
+    3885 PUSHACC3 
+    3886 MAKEBLOCK3 0
+    3888 POP 2
+    3890 RETURN 1
+    3892 RESTART 
+    3893 GRAB 1
+    3895 ACC1 
+    3896 PUSHENVACC1 
+    3897 CLOSUREREC 2, 3863
+    3901 ACC1 
+    3902 GETFIELD1 
+    3903 VECTLENGTH 
+    3904 PUSHACC3 
+    3905 PUSHENVACC1 
+    3906 GETFIELD1 
+    3907 APPLY1 
+    3908 MODINT 
+    3909 PUSHACC0 
+    3910 PUSHACC3 
+    3911 GETFIELD1 
+    3912 C_CALL2 array_get_addr
+    3914 PUSHACC2 
+    3915 APPLY1 
+    3916 PUSHACC1 
+    3917 PUSHACC4 
+    3918 GETFIELD1 
+    3919 C_CALL3 array_set_addr
+    3921 RETURN 4
+    3923 RESTART 
+    3924 GRAB 2
+    3926 ACC0 
+    3927 GETFIELD1 
+    3928 VECTLENGTH 
+    3929 PUSHACC2 
+    3930 PUSHENVACC3 
+    3931 GETFIELD1 
+    3932 APPLY1 
+    3933 MODINT 
+    3934 PUSHACC0 
+    3935 PUSHACC2 
+    3936 GETFIELD1 
+    3937 C_CALL2 array_get_addr
+    3939 PUSHACC4 
+    3940 PUSHACC4 
+    3941 MAKEBLOCK3 0
+    3943 PUSHACC0 
+    3944 PUSHACC2 
+    3945 PUSHACC4 
+    3946 GETFIELD1 
+    3947 C_CALL3 array_set_addr
+    3949 ACC0 
+    3950 PUSHACC3 
+    3951 GETFIELD0 
+    3952 PUSHENVACC2 
+    3953 APPLY2 
+    3954 BRANCHIFNOT 3962
+    3956 ACC2 
+    3957 PUSHENVACC3 
+    3958 GETFIELD1 
+    3959 PUSHENVACC1 
+    3960 APPTERM2 7
+    3962 RETURN 5
+    3964 ACC0 
+    3965 PUSHENVACC 4
+    3967 PUSHENVACC3 
+    3968 CLOSURE 3, 3924
+    3971 PUSHACC1 
+    3972 CLOSURE 1, 3893
+    3975 PUSHACC2 
+    3976 CLOSURE 1, 3774
+    3979 PUSHACC3 
+    3980 CLOSURE 1, 3725
+    3983 PUSHACC4 
+    3984 CLOSURE 1, 3673
+    3987 PUSHENVACC 5
+    3989 PUSHACC1 
+    3990 PUSHACC3 
+    3991 PUSHACC5 
+    3992 PUSHACC7 
+    3993 PUSHACC 9
+    3995 PUSHENVACC2 
+    3996 PUSHENVACC1 
+    3997 MAKEBLOCK 8, 0
+    4000 RETURN 6
+    4002 ACC0 
+    4003 BRANCHIFNOT 4016
+    4005 ACC0 
+    4006 GETFIELD1 
+    4007 PUSHACC1 
+    4008 GETFIELD0 
+    4009 PUSHENVACC1 
+    4010 APPLY2 
+    4011 ACC0 
+    4012 GETFIELD2 
+    4013 PUSHOFFSETCLOSURE0 
+    4014 APPTERM1 2
+    4016 RETURN 1
+    4018 RESTART 
+    4019 GRAB 1
+    4021 ACC0 
+    4022 CLOSUREREC 1, 4002
+    4026 ACC2 
+    4027 GETFIELD1 
+    4028 PUSHCONST0 
+    4029 PUSHACC1 
+    4030 VECTLENGTH 
+    4031 OFFSETINT -1
+    4033 PUSH 
+    4034 BRANCH 4048
+    4036 CHECK_SIGNALS 
+    4037 ACC1 
+    4038 PUSHACC3 
+    4039 C_CALL2 array_get_addr
+    4041 PUSHACC4 
+    4042 APPLY1 
+    4043 ACC1 
+    4044 OFFSETINT 1
+    4046 ASSIGN 1
+    4048 ACC0 
+    4049 PUSHACC2 
+    4050 LEINT 
+    4051 BRANCHIF 4036
+    4053 CONST0 
+    4054 RETURN 6
+    4056 ACC0 
+    4057 BRANCHIFNOT 4071
+    4059 ENVACC1 
+    4060 PUSHACC1 
+    4061 GETFIELD0 
+    4062 C_CALL2 equal
+    4064 BRANCHIF 4071
+    4066 ACC0 
+    4067 GETFIELD2 
+    4068 PUSHOFFSETCLOSURE0 
+    4069 APPTERM1 2
+    4071 RETURN 1
+    4073 RESTART 
+    4074 GRAB 1
+    4076 ACC1 
+    4077 CLOSUREREC 1, 4056
+    4081 ACC1 
+    4082 GETFIELD1 
+    4083 VECTLENGTH 
+    4084 PUSHACC3 
+    4085 PUSHENVACC1 
+    4086 APPLY1 
+    4087 MODINT 
+    4088 PUSHACC2 
+    4089 GETFIELD1 
+    4090 C_CALL2 array_get_addr
+    4092 PUSHACC1 
+    4093 APPTERM1 4
+    4095 ACC0 
+    4096 BRANCHIFNOT 4120
+    4098 ACC0 
+    4099 GETFIELD2 
+    4100 PUSHENVACC1 
+    4101 PUSHACC2 
+    4102 GETFIELD0 
+    4103 C_CALL2 equal
+    4105 BRANCHIFNOT 4116
+    4107 ACC0 
+    4108 PUSHOFFSETCLOSURE0 
+    4109 APPLY1 
+    4110 PUSHACC2 
+    4111 GETFIELD1 
+    4112 MAKEBLOCK2 0
+    4114 RETURN 2
+    4116 ACC0 
+    4117 PUSHOFFSETCLOSURE0 
+    4118 APPTERM1 3
+    4120 RETURN 1
+    4122 RESTART 
+    4123 GRAB 1
+    4125 ACC1 
+    4126 CLOSUREREC 1, 4095
+    4130 ACC1 
+    4131 GETFIELD1 
+    4132 VECTLENGTH 
+    4133 PUSHACC3 
+    4134 PUSHENVACC1 
+    4135 APPLY1 
+    4136 MODINT 
+    4137 PUSHACC2 
+    4138 GETFIELD1 
+    4139 C_CALL2 array_get_addr
+    4141 PUSHACC1 
+    4142 APPTERM1 4
+    4144 ACC0 
+    4145 BRANCHIFNOT 4163
+    4147 ACC0 
+    4148 GETFIELD0 
+    4149 PUSHENVACC1 
+    4150 C_CALL2 equal
+    4152 BRANCHIFNOT 4158
+    4154 ACC0 
+    4155 GETFIELD1 
+    4156 RETURN 1
+    4158 ACC0 
+    4159 GETFIELD2 
+    4160 PUSHOFFSETCLOSURE0 
+    4161 APPTERM1 2
+    4163 GETGLOBAL Not_found
+    4165 MAKEBLOCK1 0
+    4167 RAISE 
+    4168 RESTART 
+    4169 GRAB 1
+    4171 ACC0 
+    4172 GETFIELD1 
+    4173 VECTLENGTH 
+    4174 PUSHACC2 
+    4175 PUSHENVACC1 
+    4176 APPLY1 
+    4177 MODINT 
+    4178 PUSHACC1 
+    4179 GETFIELD1 
+    4180 C_CALL2 array_get_addr
+    4182 PUSHACC0 
+    4183 BRANCHIFNOT 4248
+    4185 ACC0 
+    4186 GETFIELD2 
+    4187 PUSHACC1 
+    4188 GETFIELD0 
+    4189 PUSHACC4 
+    4190 C_CALL2 equal
+    4192 BRANCHIFNOT 4198
+    4194 ACC1 
+    4195 GETFIELD1 
+    4196 RETURN 4
+    4198 ACC0 
+    4199 BRANCHIFNOT 4243
+    4201 ACC0 
+    4202 GETFIELD2 
+    4203 PUSHACC1 
+    4204 GETFIELD0 
+    4205 PUSHACC5 
+    4206 C_CALL2 equal
+    4208 BRANCHIFNOT 4214
+    4210 ACC1 
+    4211 GETFIELD1 
+    4212 RETURN 5
+    4214 ACC0 
+    4215 BRANCHIFNOT 4238
+    4217 ACC0 
+    4218 GETFIELD0 
+    4219 PUSHACC5 
+    4220 C_CALL2 equal
+    4222 BRANCHIFNOT 4228
+    4224 ACC0 
+    4225 GETFIELD1 
+    4226 RETURN 5
+    4228 ACC4 
+    4229 CLOSUREREC 1, 4144
+    4233 ACC1 
+    4234 GETFIELD2 
+    4235 PUSHACC1 
+    4236 APPTERM1 7
+    4238 GETGLOBAL Not_found
+    4240 MAKEBLOCK1 0
+    4242 RAISE 
+    4243 GETGLOBAL Not_found
+    4245 MAKEBLOCK1 0
+    4247 RAISE 
+    4248 GETGLOBAL Not_found
+    4250 MAKEBLOCK1 0
+    4252 RAISE 
+    4253 ACC0 
+    4254 BRANCHIFNOT 4279
+    4256 ACC0 
+    4257 GETFIELD0 
+    4258 PUSHACC1 
+    4259 GETFIELD2 
+    4260 PUSHENVACC1 
+    4261 PUSHACC2 
+    4262 C_CALL2 equal
+    4264 BRANCHIFNOT 4269
+    4266 ACC0 
+    4267 RETURN 3
+    4269 ACC0 
+    4270 PUSHOFFSETCLOSURE0 
+    4271 APPLY1 
+    4272 PUSHACC3 
+    4273 GETFIELD1 
+    4274 PUSHACC3 
+    4275 MAKEBLOCK3 0
+    4277 POP 2
+    4279 RETURN 1
+    4281 RESTART 
+    4282 GRAB 1
+    4284 ACC1 
+    4285 CLOSUREREC 1, 4253
+    4289 ACC1 
+    4290 GETFIELD1 
+    4291 VECTLENGTH 
+    4292 PUSHACC3 
+    4293 PUSHENVACC1 
+    4294 APPLY1 
+    4295 MODINT 
+    4296 PUSHACC0 
+    4297 PUSHACC3 
+    4298 GETFIELD1 
+    4299 C_CALL2 array_get_addr
+    4301 PUSHACC2 
+    4302 APPLY1 
+    4303 PUSHACC1 
+    4304 PUSHACC4 
+    4305 GETFIELD1 
+    4306 C_CALL3 array_set_addr
+    4308 RETURN 4
+    4310 RESTART 
+    4311 GRAB 2
+    4313 ACC0 
+    4314 GETFIELD1 
+    4315 VECTLENGTH 
+    4316 PUSHACC2 
+    4317 PUSHENVACC1 
+    4318 APPLY1 
+    4319 MODINT 
+    4320 PUSHACC0 
+    4321 PUSHACC2 
+    4322 GETFIELD1 
+    4323 C_CALL2 array_get_addr
+    4325 PUSHACC4 
+    4326 PUSHACC4 
+    4327 MAKEBLOCK3 0
+    4329 PUSHACC0 
+    4330 PUSHACC2 
+    4331 PUSHACC4 
+    4332 GETFIELD1 
+    4333 C_CALL3 array_set_addr
+    4335 ACC0 
+    4336 PUSHACC3 
+    4337 GETFIELD0 
+    4338 PUSHENVACC3 
+    4339 APPLY2 
+    4340 BRANCHIFNOT 4347
+    4342 ACC2 
+    4343 PUSHENVACC1 
+    4344 PUSHENVACC2 
+    4345 APPTERM2 7
+    4347 RETURN 5
+    4349 ACC0 
+    4350 BRANCHIFNOT 4378
+    4352 ACC0 
+    4353 GETFIELD0 
+    4354 PUSHACC1 
+    4355 GETFIELD2 
+    4356 PUSHOFFSETCLOSURE0 
+    4357 APPLY1 
+    4358 ENVACC2 
+    4359 PUSHACC1 
+    4360 PUSHENVACC1 
+    4361 APPLY1 
+    4362 MODINT 
+    4363 PUSHACC0 
+    4364 PUSHENVACC3 
+    4365 C_CALL2 array_get_addr
+    4367 PUSHACC3 
+    4368 GETFIELD1 
+    4369 PUSHACC3 
+    4370 MAKEBLOCK3 0
+    4372 PUSHACC1 
+    4373 PUSHENVACC3 
+    4374 C_CALL3 array_set_addr
+    4376 POP 2
+    4378 RETURN 1
+    4380 RESTART 
+    4381 GRAB 1
+    4383 ACC1 
+    4384 GETFIELD1 
+    4385 PUSHACC0 
+    4386 VECTLENGTH 
+    4387 PUSHACC0 
+    4388 PUSHCONST2 
+    4389 MULINT 
+    4390 OFFSETINT 1
+    4392 PUSHCONST0 
+    4393 PUSHACC1 
+    4394 C_CALL2 make_vect
+    4396 PUSHACC0 
+    4397 PUSHACC2 
+    4398 PUSHACC6 
+    4399 CLOSUREREC 3, 4349
+    4403 CONST0 
+    4404 PUSHACC4 
+    4405 OFFSETINT -1
+    4407 PUSH 
+    4408 BRANCH 4422
+    4410 CHECK_SIGNALS 
+    4411 ACC1 
+    4412 PUSHACC7 
+    4413 C_CALL2 array_get_addr
+    4415 PUSHACC3 
+    4416 APPLY1 
+    4417 ACC1 
+    4418 OFFSETINT 1
+    4420 ASSIGN 1
+    4422 ACC0 
+    4423 PUSHACC2 
+    4424 LEINT 
+    4425 BRANCHIF 4410
+    4427 CONST0 
+    4428 POP 2
+    4430 ACC1 
+    4431 PUSHACC7 
+    4432 SETFIELD1 
+    4433 ACC6 
+    4434 GETFIELD0 
+    4435 PUSHCONST2 
+    4436 MULINT 
+    4437 PUSHACC7 
+    4438 SETFIELD0 
+    4439 RETURN 7
+    4441 CONST0 
+    4442 PUSHACC1 
+    4443 GETFIELD1 
+    4444 VECTLENGTH 
+    4445 OFFSETINT -1
+    4447 PUSH 
+    4448 BRANCH 4462
+    4450 CHECK_SIGNALS 
+    4451 CONST0 
+    4452 PUSHACC2 
+    4453 PUSHACC4 
+    4454 GETFIELD1 
+    4455 C_CALL3 array_set_addr
+    4457 ACC1 
+    4458 OFFSETINT 1
+    4460 ASSIGN 1
+    4462 ACC0 
+    4463 PUSHACC2 
+    4464 LEINT 
+    4465 BRANCHIF 4450
+    4467 CONST0 
+    4468 RETURN 3
+    4470 CONST1 
+    4471 PUSHACC1 
+    4472 LTINT 
+    4473 BRANCHIFNOT 4478
+    4475 CONST1 
+    4476 BRANCH 4479
+    4478 ACC0 
+    4479 PUSHGETGLOBALFIELD Sys, 5
+    4482 PUSHACC1 
+    4483 GTINT 
+    4484 BRANCHIFNOT 4491
+    4486 GETGLOBALFIELD Sys, 5
+    4489 BRANCH 4492
+    4491 ACC0 
+    4492 PUSHCONST0 
+    4493 PUSHACC1 
+    4494 C_CALL2 make_vect
+    4496 PUSHCONST3 
+    4497 MAKEBLOCK2 0
+    4499 RETURN 3
+    4501 ACC0 
+    4502 PUSHCONSTINT 100
+    4504 PUSHCONSTINT 10
+    4506 C_CALL3 hash_univ_param
+    4508 RETURN 1
+    4510 CLOSURE 0, 4501
+    4513 PUSH 
+    4514 CLOSURE 0, 4470
+    4517 PUSH 
+    4518 CLOSURE 0, 4441
+    4521 PUSH 
+    4522 CLOSURE 0, 4381
+    4525 PUSH 
+    4526 CLOSUREREC 0, 3631
+    4530 ACC0 
+    4531 PUSHACC2 
+    4532 PUSHACC6 
+    4533 CLOSURE 3, 4311
+    4536 PUSHACC5 
+    4537 CLOSURE 1, 4282
+    4540 PUSHACC6 
+    4541 CLOSURE 1, 4169
+    4544 PUSHACC7 
+    4545 CLOSURE 1, 4123
+    4548 PUSHACC 8
+    4550 CLOSURE 1, 4074
+    4553 PUSH 
+    4554 CLOSURE 0, 4019
+    4557 PUSHACC0 
+    4558 PUSHACC7 
+    4559 PUSHACC 9
+    4561 PUSHACC 11
+    4563 PUSHACC 13
+    4565 CLOSURE 5, 3964
+    4568 PUSHACC 11
+    4570 PUSHACC1 
+    4571 PUSHACC3 
+    4572 PUSHACC 8
+    4574 PUSHACC6 
+    4575 PUSHACC 8
+    4577 PUSHACC 10
+    4579 PUSHACC 13
+    4581 PUSHACC 17
+    4583 PUSHACC 19
+    4585 MAKEBLOCK 10, 0
+    4588 POP 12
+    4590 SETGLOBAL Hashtbl
+    4592 BRANCH 5073
+    4594 RESTART 
+    4595 GRAB 2
+    4597 ACC1 
+    4598 BRANCHIFNOT 4638
+    4600 ACC1 
+    4601 GETFIELD0 
+    4602 PUSHACC3 
+    4603 BRANCHIFNOT 4635
+    4605 ACC3 
+    4606 GETFIELD0 
+    4607 PUSHACC0 
+    4608 PUSHACC2 
+    4609 PUSHACC4 
+    4610 APPLY2 
+    4611 BRANCHIFNOT 4624
+    4613 ACC4 
+    4614 PUSHACC4 
+    4615 GETFIELD1 
+    4616 PUSHACC4 
+    4617 PUSHOFFSETCLOSURE0 
+    4618 APPLY3 
+    4619 PUSHACC2 
+    4620 MAKEBLOCK2 0
+    4622 RETURN 5
+    4624 ACC4 
+    4625 GETFIELD1 
+    4626 PUSHACC4 
+    4627 PUSHACC4 
+    4628 PUSHOFFSETCLOSURE0 
+    4629 APPLY3 
+    4630 PUSHACC1 
+    4631 MAKEBLOCK2 0
+    4633 RETURN 5
+    4635 ACC2 
+    4636 RETURN 4
+    4638 ACC2 
+    4639 RETURN 3
+    4641 RESTART 
+    4642 GRAB 1
+    4644 CONSTINT 6
+    4646 PUSHACC1 
+    4647 PUSHACC3 
+    4648 SUBINT 
+    4649 GEINT 
+    4650 BRANCHIFNOT 4809
+    4652 CONST1 
+    4653 PUSHACC2 
+    4654 PUSHACC2 
+    4655 ADDINT 
+    4656 LSRINT 
+    4657 PUSHACC1 
+    4658 PUSHENVACC3 
+    4659 C_CALL2 array_unsafe_get
+    4661 PUSHACC1 
+    4662 PUSHENVACC3 
+    4663 C_CALL2 array_unsafe_get
+    4665 PUSHENVACC2 
+    4666 APPLY2 
+    4667 BRANCHIFNOT 4674
+    4669 ACC1 
+    4670 PUSHACC1 
+    4671 PUSHENVACC3 
+    4672 PUSHENVACC1 
+    4673 APPLY3 
+    4674 ACC0 
+    4675 PUSHENVACC3 
+    4676 C_CALL2 array_unsafe_get
+    4678 PUSHACC3 
+    4679 PUSHENVACC3 
+    4680 C_CALL2 array_unsafe_get
+    4682 PUSHENVACC2 
+    4683 APPLY2 
+    4684 BRANCHIFNOT 4708
+    4686 ACC2 
+    4687 PUSHACC1 
+    4688 PUSHENVACC3 
+    4689 PUSHENVACC1 
+    4690 APPLY3 
+    4691 ACC1 
+    4692 PUSHENVACC3 
+    4693 C_CALL2 array_unsafe_get
+    4695 PUSHACC1 
+    4696 PUSHENVACC3 
+    4697 C_CALL2 array_unsafe_get
+    4699 PUSHENVACC2 
+    4700 APPLY2 
+    4701 BRANCHIFNOT 4708
+    4703 ACC1 
+    4704 PUSHACC1 
+    4705 PUSHENVACC3 
+    4706 PUSHENVACC1 
+    4707 APPLY3 
+    4708 ACC0 
+    4709 PUSHENVACC3 
+    4710 C_CALL2 array_unsafe_get
+    4712 PUSHACC2 
+    4713 OFFSETINT 1
+    4715 PUSHACC4 
+    4716 OFFSETINT -1
+    4718 PUSH 
+    4719 BRANCH 4777
+    4721 CHECK_SIGNALS 
+    4722 BRANCH 4730
+    4724 CHECK_SIGNALS 
+    4725 ACC1 
+    4726 OFFSETINT 1
+    4728 ASSIGN 1
+    4730 ACC1 
+    4731 PUSHENVACC3 
+    4732 C_CALL2 array_unsafe_get
+    4734 PUSHACC3 
+    4735 PUSHENVACC2 
+    4736 APPLY2 
+    4737 BRANCHIFNOT 4724
+    4739 CONST0 
+    4740 BRANCH 4748
+    4742 CHECK_SIGNALS 
+    4743 ACC0 
+    4744 OFFSETINT -1
+    4746 ASSIGN 0
+    4748 ACC2 
+    4749 PUSHACC1 
+    4750 PUSHENVACC3 
+    4751 C_CALL2 array_unsafe_get
+    4753 PUSHENVACC2 
+    4754 APPLY2 
+    4755 BRANCHIFNOT 4742
+    4757 ACC0 
+    4758 PUSHACC2 
+    4759 LTINT 
+    4760 BRANCHIFNOT 4767
+    4762 ACC0 
+    4763 PUSHACC2 
+    4764 PUSHENVACC3 
+    4765 PUSHENVACC1 
+    4766 APPLY3 
+    4767 ACC1 
+    4768 OFFSETINT 1
+    4770 ASSIGN 1
+    4772 ACC0 
+    4773 OFFSETINT -1
+    4775 ASSIGN 0
+    4777 ACC0 
+    4778 PUSHACC2 
+    4779 LTINT 
+    4780 BRANCHIF 4721
+    4782 ACC1 
+    4783 PUSHACC6 
+    4784 SUBINT 
+    4785 PUSHACC5 
+    4786 PUSHACC2 
+    4787 SUBINT 
+    4788 LEINT 
+    4789 BRANCHIFNOT 4800
+    4791 ACC0 
+    4792 PUSHACC5 
+    4793 PUSHOFFSETCLOSURE0 
+    4794 APPLY2 
+    4795 ACC5 
+    4796 PUSHACC2 
+    4797 PUSHOFFSETCLOSURE0 
+    4798 APPTERM2 8
+    4800 ACC5 
+    4801 PUSHACC2 
+    4802 PUSHOFFSETCLOSURE0 
+    4803 APPLY2 
+    4804 ACC0 
+    4805 PUSHACC5 
+    4806 PUSHOFFSETCLOSURE0 
+    4807 APPTERM2 8
+    4809 RETURN 2
+    4811 RESTART 
+    4812 GRAB 1
+    4814 ACC1 
+    4815 PUSHACC1 
+    4816 PUSHENVACC1 
+    4817 CLOSUREREC 3, 4642
+    4821 ACC2 
+    4822 VECTLENGTH 
+    4823 OFFSETINT -1
+    4825 PUSHCONST0 
+    4826 PUSHACC2 
+    4827 APPLY2 
+    4828 CONST1 
+    4829 PUSHACC3 
+    4830 VECTLENGTH 
+    4831 OFFSETINT -1
+    4833 PUSH 
+    4834 BRANCH 4918
+    4836 CHECK_SIGNALS 
+    4837 ACC1 
+    4838 PUSHACC5 
+    4839 C_CALL2 array_unsafe_get
+    4841 PUSHACC0 
+    4842 PUSHACC3 
+    4843 OFFSETINT -1
+    4845 PUSHACC7 
+    4846 C_CALL2 array_unsafe_get
+    4848 PUSHACC6 
+    4849 APPLY2 
+    4850 BOOLNOT 
+    4851 BRANCHIFNOT 4911
+    4853 ACC2 
+    4854 OFFSETINT -1
+    4856 PUSHACC6 
+    4857 C_CALL2 array_unsafe_get
+    4859 PUSHACC3 
+    4860 PUSHACC7 
+    4861 C_CALL3 array_unsafe_set
+    4863 ACC2 
+    4864 OFFSETINT -1
+    4866 PUSH 
+    4867 BRANCH 4886
+    4869 CHECK_SIGNALS 
+    4870 ACC0 
+    4871 OFFSETINT -1
+    4873 PUSHACC7 
+    4874 C_CALL2 array_unsafe_get
+    4876 PUSHACC1 
+    4877 PUSHACC 8
+    4879 C_CALL3 array_unsafe_set
+    4881 ACC0 
+    4882 OFFSETINT -1
+    4884 ASSIGN 0
+    4886 CONST1 
+    4887 PUSHACC1 
+    4888 GEINT 
+    4889 BRANCHIFNOT 4903
+    4891 ACC1 
+    4892 PUSHACC1 
+    4893 OFFSETINT -1
+    4895 PUSHACC 8
+    4897 C_CALL2 array_unsafe_get
+    4899 PUSHACC7 
+    4900 APPLY2 
+    4901 BRANCHIFNOT 4869
+    4903 ACC1 
+    4904 PUSHACC1 
+    4905 PUSHACC 8
+    4907 C_CALL3 array_unsafe_set
+    4909 POP 1
+    4911 POP 1
+    4913 ACC1 
+    4914 OFFSETINT 1
+    4916 ASSIGN 1
+    4918 ACC0 
+    4919 PUSHACC2 
+    4920 LEINT 
+    4921 BRANCHIF 4836
+    4923 CONST0 
+    4924 RETURN 5
+    4926 RESTART 
+    4927 GRAB 2
+    4929 ACC1 
+    4930 PUSHACC1 
+    4931 C_CALL2 array_unsafe_get
+    4933 PUSHACC3 
+    4934 PUSHACC2 
+    4935 C_CALL2 array_unsafe_get
+    4937 PUSHACC3 
+    4938 PUSHACC3 
+    4939 C_CALL3 array_unsafe_set
+    4941 ACC0 
+    4942 PUSHACC4 
+    4943 PUSHACC3 
+    4944 C_CALL3 array_unsafe_set
+    4946 RETURN 4
+    4948 ACC0 
+    4949 BRANCHIFNOT 4999
+    4951 ACC0 
+    4952 GETFIELD0 
+    4953 PUSHACC1 
+    4954 GETFIELD1 
+    4955 PUSHACC0 
+    4956 BRANCHIFNOT 4990
+    4958 ACC0 
+    4959 GETFIELD0 
+    4960 PUSHACC1 
+    4961 GETFIELD1 
+    4962 PUSHOFFSETCLOSURE0 
+    4963 APPLY1 
+    4964 PUSHACC1 
+    4965 PUSHACC4 
+    4966 PUSHENVACC1 
+    4967 APPLY2 
+    4968 BRANCHIFNOT 4979
+    4970 CONST0 
+    4971 PUSHACC2 
+    4972 MAKEBLOCK2 0
+    4974 PUSHACC4 
+    4975 MAKEBLOCK2 0
+    4977 BRANCH 4986
+    4979 CONST0 
+    4980 PUSHACC4 
+    4981 MAKEBLOCK2 0
+    4983 PUSHACC2 
+    4984 MAKEBLOCK2 0
+    4986 MAKEBLOCK2 0
+    4988 RETURN 4
+    4990 CONST0 
+    4991 PUSHCONST0 
+    4992 PUSHACC3 
+    4993 MAKEBLOCK2 0
+    4995 MAKEBLOCK2 0
+    4997 POP 2
+    4999 RETURN 1
+    5001 ACC0 
+    5002 BRANCHIFNOT 5028
+    5004 ACC0 
+    5005 GETFIELD1 
+    5006 PUSHACC0 
+    5007 BRANCHIFNOT 5024
+    5009 ACC0 
+    5010 GETFIELD1 
+    5011 PUSHOFFSETCLOSURE0 
+    5012 APPLY1 
+    5013 PUSHACC1 
+    5014 GETFIELD0 
+    5015 PUSHACC3 
+    5016 GETFIELD0 
+    5017 PUSHENVACC2 
+    5018 PUSHENVACC1 
+    5019 APPLY3 
+    5020 MAKEBLOCK2 0
+    5022 RETURN 2
+    5024 POP 1
+    5026 BRANCH 5028
+    5028 ACC0 
+    5029 RETURN 1
+    5031 ACC0 
+    5032 BRANCHIFNOT 5040
+    5034 ACC0 
+    5035 GETFIELD1 
+    5036 BRANCHIF 5042
+    5038 ACC0 
+    5039 GETFIELD0 
+    5040 RETURN 1
+    5042 ACC0 
+    5043 PUSHENVACC1 
+    5044 APPLY1 
+    5045 PUSHOFFSETCLOSURE0 
+    5046 APPTERM1 2
+    5048 RESTART 
+    5049 GRAB 1
+    5051 ACC0 
+    5052 CLOSUREREC 1, 4948
+    5056 ACC1 
+    5057 PUSHENVACC1 
+    5058 CLOSUREREC 2, 5001
+    5062 ACC0 
+    5063 CLOSUREREC 1, 5031
+    5067 ACC4 
+    5068 PUSHACC3 
+    5069 APPLY1 
+    5070 PUSHACC1 
+    5071 APPTERM1 6
+    5073 CLOSUREREC 0, 4595
+    5077 ACC0 
+    5078 CLOSURE 1, 5049
+    5081 PUSH 
+    5082 CLOSURE 0, 4927
+    5085 PUSHACC0 
+    5086 CLOSURE 1, 4812
+    5089 PUSHACC3 
+    5090 PUSHACC1 
+    5091 PUSHACC4 
+    5092 MAKEBLOCK3 0
+    5094 POP 4
+    5096 SETGLOBAL Sort
+    5098 BRANCH 5847
+    5100 ACC0 
+    5101 PUSHENVACC1 
+    5102 APPLY1 
+    5103 PUSHACC0 
+    5104 GETFIELD 11
+    5106 PUSHACC1 
+    5107 GETFIELD 10
+    5109 PUSHACC2 
+    5110 GETFIELD 9
+    5112 PUSHACC3 
+    5113 GETFIELD 6
+    5115 PUSHACC4 
+    5116 GETFIELD 8
+    5118 PUSHACC5 
+    5119 GETFIELD 5
+    5121 PUSHACC6 
+    5122 GETFIELD 4
+    5124 PUSHACC7 
+    5125 GETFIELD0 
+    5126 MAKEBLOCK 8, 0
+    5129 RETURN 2
+    5131 RESTART 
+    5132 GRAB 2
+    5134 ACC2 
+    5135 BRANCHIFNOT 5201
+    5137 ACC2 
+    5138 GETFIELD0 
+    5139 PUSHACC3 
+    5140 GETFIELD1 
+    5141 PUSHACC4 
+    5142 GETFIELD2 
+    5143 PUSHACC5 
+    5144 GETFIELD3 
+    5145 PUSHACC2 
+    5146 PUSHACC5 
+    5147 PUSHENVACC1 
+    5148 GETFIELD0 
+    5149 APPLY2 
+    5150 PUSHCONST0 
+    5151 PUSHACC1 
+    5152 EQ 
+    5153 BRANCHIFNOT 5170
+    5155 ACC7 
+    5156 GETFIELD 4
+    5158 PUSHACC2 
+    5159 PUSHACC 8
+    5161 PUSHACC 8
+    5163 PUSHACC 8
+    5165 MAKEBLOCK 5, 0
+    5168 RETURN 8
+    5170 CONST0 
+    5171 PUSHACC1 
+    5172 LTINT 
+    5173 BRANCHIFNOT 5189
+    5175 ACC1 
+    5176 PUSHACC3 
+    5177 PUSHACC5 
+    5178 PUSHACC7 
+    5179 PUSHACC 10
+    5181 PUSHACC 10
+    5183 PUSHOFFSETCLOSURE0 
+    5184 APPLY3 
+    5185 PUSHENVACC2 
+    5186 APPTERM 4, 12
+    5189 ACC1 
+    5190 PUSHACC7 
+    5191 PUSHACC7 
+    5192 PUSHOFFSETCLOSURE0 
+    5193 APPLY3 
+    5194 PUSHACC3 
+    5195 PUSHACC5 
+    5196 PUSHACC7 
+    5197 PUSHENVACC2 
+    5198 APPTERM 4, 12
+    5201 CONST1 
+    5202 PUSHCONST0 
+    5203 PUSHACC3 
+    5204 PUSHACC3 
+    5205 PUSHCONST0 
+    5206 MAKEBLOCK 5, 0
+    5209 RETURN 3
+    5211 RESTART 
+    5212 GRAB 1
+    5214 ACC1 
+    5215 BRANCHIFNOT 5247
+    5217 ACC1 
+    5218 GETFIELD1 
+    5219 PUSHACC1 
+    5220 PUSHENVACC1 
+    5221 GETFIELD0 
+    5222 APPLY2 
+    5223 PUSHCONST0 
+    5224 PUSHACC1 
+    5225 EQ 
+    5226 BRANCHIFNOT 5232
+    5228 ACC2 
+    5229 GETFIELD2 
+    5230 RETURN 3
+    5232 CONST0 
+    5233 PUSHACC1 
+    5234 LTINT 
+    5235 BRANCHIFNOT 5241
+    5237 ACC2 
+    5238 GETFIELD0 
+    5239 BRANCH 5243
+    5241 ACC2 
+    5242 GETFIELD3 
+    5243 PUSHACC2 
+    5244 PUSHOFFSETCLOSURE0 
+    5245 APPTERM2 5
+    5247 GETGLOBAL Not_found
+    5249 MAKEBLOCK1 0
+    5251 RAISE 
+    5252 RESTART 
+    5253 GRAB 1
+    5255 ACC1 
+    5256 BRANCHIFNOT 5286
+    5258 ACC1 
+    5259 GETFIELD1 
+    5260 PUSHACC1 
+    5261 PUSHENVACC1 
+    5262 GETFIELD0 
+    5263 APPLY2 
+    5264 PUSHCONST0 
+    5265 PUSHACC1 
+    5266 EQ 
+    5267 BRANCHIF 5284
+    5269 CONST0 
+    5270 PUSHACC1 
+    5271 LTINT 
+    5272 BRANCHIFNOT 5278
+    5274 ACC2 
+    5275 GETFIELD0 
+    5276 BRANCH 5280
+    5278 ACC2 
+    5279 GETFIELD3 
+    5280 PUSHACC2 
+    5281 PUSHOFFSETCLOSURE0 
+    5282 APPTERM2 5
+    5284 POP 1
+    5286 RETURN 2
+    5288 RESTART 
+    5289 GRAB 1
+    5291 ACC0 
+    5292 BRANCHIF 5297
+    5294 ACC1 
+    5295 RETURN 2
+    5297 ACC1 
+    5298 BRANCHIF 5303
+    5300 ACC0 
+    5301 RETURN 2
+    5303 ACC0 
+    5304 BRANCHIFNOT 5336
+    5306 ACC1 
+    5307 BRANCHIFNOT 5336
+    5309 PUSH_RETADDR 5326
+    5311 ACC4 
+    5312 GETFIELD3 
+    5313 PUSHACC5 
+    5314 GETFIELD2 
+    5315 PUSHACC6 
+    5316 GETFIELD1 
+    5317 PUSHACC7 
+    5318 GETFIELD0 
+    5319 PUSHACC7 
+    5320 GETFIELD3 
+    5321 PUSHOFFSETCLOSURE0 
+    5322 APPLY2 
+    5323 PUSHENVACC1 
+    5324 APPLY 4
+    5326 PUSHACC1 
+    5327 GETFIELD2 
+    5328 PUSHACC2 
+    5329 GETFIELD1 
+    5330 PUSHACC3 
+    5331 GETFIELD0 
+    5332 PUSHENVACC1 
+    5333 APPTERM 4, 6
+    5336 GETGLOBAL <0>("map.ml", 3614, 3797)
+    5338 PUSHGETGLOBAL Match_failure
+    5340 MAKEBLOCK2 0
+    5342 RAISE 
+    5343 RESTART 
+    5344 GRAB 1
+    5346 ACC1 
+    5347 BRANCHIFNOT 5400
+    5349 ACC1 
+    5350 GETFIELD0 
+    5351 PUSHACC2 
+    5352 GETFIELD1 
+    5353 PUSHACC3 
+    5354 GETFIELD2 
+    5355 PUSHACC4 
+    5356 GETFIELD3 
+    5357 PUSHACC2 
+    5358 PUSHACC5 
+    5359 PUSHENVACC1 
+    5360 GETFIELD0 
+    5361 APPLY2 
+    5362 PUSHCONST0 
+    5363 PUSHACC1 
+    5364 EQ 
+    5365 BRANCHIFNOT 5372
+    5367 ACC1 
+    5368 PUSHACC5 
+    5369 PUSHENVACC3 
+    5370 APPTERM2 9
+    5372 CONST0 
+    5373 PUSHACC1 
+    5374 LTINT 
+    5375 BRANCHIFNOT 5389
+    5377 ACC1 
+    5378 PUSHACC3 
+    5379 PUSHACC5 
+    5380 PUSHACC7 
+    5381 PUSHACC 9
+    5383 PUSHOFFSETCLOSURE0 
+    5384 APPLY2 
+    5385 PUSHENVACC2 
+    5386 APPTERM 4, 11
+    5389 ACC1 
+    5390 PUSHACC6 
+    5391 PUSHOFFSETCLOSURE0 
+    5392 APPLY2 
+    5393 PUSHACC3 
+    5394 PUSHACC5 
+    5395 PUSHACC7 
+    5396 PUSHENVACC2 
+    5397 APPTERM 4, 11
+    5400 RETURN 2
+    5402 RESTART 
+    5403 GRAB 1
+    5405 ACC1 
+    5406 BRANCHIFNOT 5425
+    5408 ACC1 
+    5409 GETFIELD0 
+    5410 PUSHACC1 
+    5411 PUSHOFFSETCLOSURE0 
+    5412 APPLY2 
+    5413 ACC1 
+    5414 GETFIELD2 
+    5415 PUSHACC2 
+    5416 GETFIELD1 
+    5417 PUSHACC2 
+    5418 APPLY2 
+    5419 ACC1 
+    5420 GETFIELD3 
+    5421 PUSHACC1 
+    5422 PUSHOFFSETCLOSURE0 
+    5423 APPTERM2 4
+    5425 RETURN 2
+    5427 RESTART 
+    5428 GRAB 1
+    5430 ACC1 
+    5431 BRANCHIFNOT 5455
+    5433 ACC1 
+    5434 GETFIELD 4
+    5436 PUSHACC2 
+    5437 GETFIELD3 
+    5438 PUSHACC2 
+    5439 PUSHOFFSETCLOSURE0 
+    5440 APPLY2 
+    5441 PUSHACC3 
+    5442 GETFIELD2 
+    5443 PUSHACC3 
+    5444 APPLY1 
+    5445 PUSHACC4 
+    5446 GETFIELD1 
+    5447 PUSHACC5 
+    5448 GETFIELD0 
+    5449 PUSHACC5 
+    5450 PUSHOFFSETCLOSURE0 
+    5451 APPLY2 
+    5452 MAKEBLOCK 5, 0
+    5455 RETURN 2
+    5457 RESTART 
+    5458 GRAB 2
+    5460 ACC1 
+    5461 BRANCHIFNOT 5481
+    5463 ACC2 
+    5464 PUSHACC2 
+    5465 GETFIELD3 
+    5466 PUSHACC2 
+    5467 PUSHOFFSETCLOSURE0 
+    5468 APPLY3 
+    5469 PUSHACC2 
+    5470 GETFIELD2 
+    5471 PUSHACC3 
+    5472 GETFIELD1 
+    5473 PUSHACC3 
+    5474 APPLY3 
+    5475 PUSHACC2 
+    5476 GETFIELD0 
+    5477 PUSHACC2 
+    5478 PUSHOFFSETCLOSURE0 
+    5479 APPTERM3 6
+    5481 ACC2 
+    5482 RETURN 3
+    5484 RESTART 
+    5485 GRAB 3
+    5487 ACC0 
+    5488 BRANCHIFNOT 5495
+    5490 ACC0 
+    5491 GETFIELD 4
+    5493 BRANCH 5496
+    5495 CONST0 
+    5496 PUSHACC4 
+    5497 BRANCHIFNOT 5504
+    5499 ACC4 
+    5500 GETFIELD 4
+    5502 BRANCH 5505
+    5504 CONST0 
+    5505 PUSHACC0 
+    5506 OFFSETINT 2
+    5508 PUSHACC2 
+    5509 GTINT 
+    5510 BRANCHIFNOT 5603
+    5512 ACC2 
+    5513 BRANCHIFNOT 5596
+    5515 ACC2 
+    5516 GETFIELD0 
+    5517 PUSHACC3 
+    5518 GETFIELD1 
+    5519 PUSHACC4 
+    5520 GETFIELD2 
+    5521 PUSHACC5 
+    5522 GETFIELD3 
+    5523 PUSHACC0 
+    5524 PUSHENVACC1 
+    5525 APPLY1 
+    5526 PUSHACC4 
+    5527 PUSHENVACC1 
+    5528 APPLY1 
+    5529 GEINT 
+    5530 BRANCHIFNOT 5551
+    5532 PUSH_RETADDR 5544
+    5534 ACC 12
+    5536 PUSHACC 12
+    5538 PUSHACC 12
+    5540 PUSHACC6 
+    5541 PUSHENVACC2 
+    5542 APPLY 4
+    5544 PUSHACC2 
+    5545 PUSHACC4 
+    5546 PUSHACC6 
+    5547 PUSHENVACC2 
+    5548 APPTERM 4, 14
+    5551 ACC0 
+    5552 BRANCHIFNOT 5589
+    5554 PUSH_RETADDR 5567
+    5556 ACC 12
+    5558 PUSHACC 12
+    5560 PUSHACC 12
+    5562 PUSHACC6 
+    5563 GETFIELD3 
+    5564 PUSHENVACC2 
+    5565 APPLY 4
+    5567 PUSHACC1 
+    5568 GETFIELD2 
+    5569 PUSHACC2 
+    5570 GETFIELD1 
+    5571 PUSH 
+    5572 PUSH_RETADDR 5585
+    5574 ACC6 
+    5575 GETFIELD0 
+    5576 PUSHACC 8
+    5578 PUSHACC 10
+    5580 PUSHACC 12
+    5582 PUSHENVACC2 
+    5583 APPLY 4
+    5585 PUSHENVACC2 
+    5586 APPTERM 4, 14
+    5589 GETGLOBAL "Map.bal"
+    5591 PUSHGETGLOBALFIELD Pervasives, 2
+    5594 APPTERM1 11
+    5596 GETGLOBAL "Map.bal"
+    5598 PUSHGETGLOBALFIELD Pervasives, 2
+    5601 APPTERM1 7
+    5603 ACC1 
+    5604 OFFSETINT 2
+    5606 PUSHACC1 
+    5607 GTINT 
+    5608 BRANCHIFNOT 5703
+    5610 ACC5 
+    5611 BRANCHIFNOT 5696
+    5613 ACC5 
+    5614 GETFIELD0 
+    5615 PUSHACC6 
+    5616 GETFIELD1 
+    5617 PUSHACC7 
+    5618 GETFIELD2 
+    5619 PUSHACC 8
+    5621 GETFIELD3 
+    5622 PUSHACC3 
+    5623 PUSHENVACC1 
+    5624 APPLY1 
+    5625 PUSHACC1 
+    5626 PUSHENVACC1 
+    5627 APPLY1 
+    5628 GEINT 
+    5629 BRANCHIFNOT 5652
+    5631 ACC0 
+    5632 PUSHACC2 
+    5633 PUSHACC4 
+    5634 PUSH 
+    5635 PUSH_RETADDR 5648
+    5637 ACC 9
+    5639 PUSHACC 15
+    5641 PUSHACC 15
+    5643 PUSHACC 15
+    5645 PUSHENVACC2 
+    5646 APPLY 4
+    5648 PUSHENVACC2 
+    5649 APPTERM 4, 14
+    5652 ACC3 
+    5653 BRANCHIFNOT 5689
+    5655 PUSH_RETADDR 5666
+    5657 ACC3 
+    5658 PUSHACC5 
+    5659 PUSHACC7 
+    5660 PUSHACC 9
+    5662 GETFIELD3 
+    5663 PUSHENVACC2 
+    5664 APPLY 4
+    5666 PUSHACC4 
+    5667 GETFIELD2 
+    5668 PUSHACC5 
+    5669 GETFIELD1 
+    5670 PUSH 
+    5671 PUSH_RETADDR 5685
+    5673 ACC 9
+    5675 GETFIELD0 
+    5676 PUSHACC 15
+    5678 PUSHACC 15
+    5680 PUSHACC 15
+    5682 PUSHENVACC2 
+    5683 APPLY 4
+    5685 PUSHENVACC2 
+    5686 APPTERM 4, 14
+    5689 GETGLOBAL "Map.bal"
+    5691 PUSHGETGLOBALFIELD Pervasives, 2
+    5694 APPTERM1 11
+    5696 GETGLOBAL "Map.bal"
+    5698 PUSHGETGLOBALFIELD Pervasives, 2
+    5701 APPTERM1 7
+    5703 ACC0 
+    5704 PUSHACC2 
+    5705 GEINT 
+    5706 BRANCHIFNOT 5713
+    5708 ACC1 
+    5709 OFFSETINT 1
+    5711 BRANCH 5716
+    5713 ACC0 
+    5714 OFFSETINT 1
+    5716 PUSHACC6 
+    5717 PUSHACC6 
+    5718 PUSHACC6 
+    5719 PUSHACC6 
+    5720 MAKEBLOCK 5, 0
+    5723 RETURN 6
+    5725 RESTART 
+    5726 GRAB 3
+    5728 ACC0 
+    5729 PUSHENVACC1 
+    5730 APPLY1 
+    5731 PUSHACC4 
+    5732 PUSHENVACC1 
+    5733 APPLY1 
+    5734 PUSHACC0 
+    5735 PUSHACC2 
+    5736 GEINT 
+    5737 BRANCHIFNOT 5744
+    5739 ACC1 
+    5740 OFFSETINT 1
+    5742 BRANCH 5747
+    5744 ACC0 
+    5745 OFFSETINT 1
+    5747 PUSHACC6 
+    5748 PUSHACC6 
+    5749 PUSHACC6 
+    5750 PUSHACC6 
+    5751 MAKEBLOCK 5, 0
+    5754 RETURN 6
+    5756 ACC0 
+    5757 BRANCHIFNOT 5764
+    5759 ACC0 
+    5760 GETFIELD 4
+    5762 RETURN 1
+    5764 CONST0 
+    5765 RETURN 1
+    5767 CONST0 
+    5768 PUSH 
+    5769 CLOSURE 0, 5756
+    5772 PUSHACC0 
+    5773 CLOSURE 1, 5726
+    5776 PUSHACC0 
+    5777 PUSHACC2 
+    5778 CLOSURE 2, 5485
+    5781 PUSHACC0 
+    5782 PUSHACC5 
+    5783 CLOSUREREC 2, 5132
+    5787 ACC5 
+    5788 CLOSUREREC 1, 5212
+    5792 ACC6 
+    5793 CLOSUREREC 1, 5253
+    5797 ACC3 
+    5798 CLOSUREREC 1, 5289
+    5802 ACC0 
+    5803 PUSHACC5 
+    5804 PUSHACC 10
+    5806 CLOSUREREC 3, 5344
+    5810 CLOSUREREC 0, 5403
+    5814 CLOSUREREC 0, 5428
+    5818 CLOSUREREC 0, 5458
+    5822 ACC0 
+    5823 PUSHACC2 
+    5824 PUSHACC4 
+    5825 PUSHACC6 
+    5826 PUSHACC 8
+    5828 PUSHACC 10
+    5830 PUSHACC 12
+    5832 PUSHACC 14
+    5834 PUSHACC 16
+    5836 PUSHACC 18
+    5838 PUSHACC 20
+    5840 PUSHACC 22
+    5842 MAKEBLOCK 12, 0
+    5845 RETURN 13
+    5847 CLOSURE 0, 5767
+    5850 PUSHACC0 
+    5851 CLOSURE 1, 5100
+    5854 MAKEBLOCK1 0
+    5856 POP 1
+    5858 SETGLOBAL Map
+    5860 BRANCH 5957
+    5862 CONSTINT 16
+    5864 C_CALL1 create_string
+    5866 PUSH 
+    5867 PUSH_RETADDR 5879
+    5869 CONSTINT 16
+    5871 PUSHCONST0 
+    5872 PUSHACC5 
+    5873 PUSHACC7 
+    5874 PUSHGETGLOBALFIELD Pervasives, 56
+    5877 APPLY 4
+    5879 ACC0 
+    5880 RETURN 2
+    5882 RESTART 
+    5883 GRAB 1
+    5885 CONSTINT 16
+    5887 PUSHCONST0 
+    5888 PUSHACC3 
+    5889 PUSHACC3 
+    5890 PUSHGETGLOBALFIELD Pervasives, 41
+    5893 APPTERM 4, 6
+    5896 ACC0 
+    5897 PUSHGETGLOBALFIELD Pervasives, 51
+    5900 APPLY1 
+    5901 PUSHACC0 
+    5902 PUSHGETGLOBALFIELD Pervasives, 62
+    5905 APPLY1 
+    5906 PUSHACC1 
+    5907 C_CALL2 md5_chan
+    5909 PUSHACC1 
+    5910 PUSHGETGLOBALFIELD Pervasives, 63
+    5913 APPLY1 
+    5914 ACC0 
+    5915 RETURN 3
+    5917 RESTART 
+    5918 GRAB 2
+    5920 CONST0 
+    5921 PUSHACC2 
+    5922 LTINT 
+    5923 BRANCHIF 5934
+    5925 ACC0 
+    5926 C_CALL1 ml_string_length
+    5928 PUSHACC3 
+    5929 PUSHACC3 
+    5930 ADDINT 
+    5931 GTINT 
+    5932 BRANCHIFNOT 5941
+    5934 GETGLOBAL "Digest.substring"
+    5936 PUSHGETGLOBALFIELD Pervasives, 2
+    5939 APPTERM1 4
+    5941 ACC2 
+    5942 PUSHACC2 
+    5943 PUSHACC2 
+    5944 C_CALL3 md5_string
+    5946 RETURN 3
+    5948 ACC0 
+    5949 C_CALL1 ml_string_length
+    5951 PUSHCONST0 
+    5952 PUSHACC2 
+    5953 C_CALL3 md5_string
+    5955 RETURN 1
+    5957 CLOSURE 0, 5948
+    5960 PUSH 
+    5961 CLOSURE 0, 5918
+    5964 PUSH 
+    5965 CLOSURE 0, 5896
+    5968 PUSH 
+    5969 CLOSURE 0, 5883
+    5972 PUSH 
+    5973 CLOSURE 0, 5862
+    5976 PUSHACC0 
+    5977 PUSHACC2 
+    5978 PUSHACC4 
+    5979 PUSHACC6 
+    5980 PUSHACC 8
+    5982 MAKEBLOCK 5, 0
+    5985 POP 5
+    5987 SETGLOBAL Digest
+    5989 BRANCH 6245
+    5991 CONST0 
+    5992 PUSHENVACC1 
+    5993 APPLY1 
+    5994 PUSHACC1 
+    5995 PUSHACC1 
+    5996 GEINT 
+    5997 BRANCHIFNOT 6003
+    5999 ACC1 
+    6000 PUSHOFFSETCLOSURE0 
+    6001 APPTERM1 3
+    6003 ACC0 
+    6004 RETURN 2
+    6006 CONST0 
+    6007 C_CALL1 sys_random_seed
+    6009 PUSHENVACC1 
+    6010 APPTERM1 2
+    6012 CONSTINT 27182818
+    6014 PUSHENVACC2 
+    6015 APPLY1 
+    6016 CONST0 
+    6017 PUSHACC1 
+    6018 VECTLENGTH 
+    6019 OFFSETINT -1
+    6021 PUSH 
+    6022 BRANCH 6046
+    6024 CHECK_SIGNALS 
+    6025 CONSTINT 55
+    6027 PUSHACC2 
+    6028 MODINT 
+    6029 PUSHACC2 
+    6030 PUSHACC4 
+    6031 GETVECTITEM 
+    6032 PUSHACC1 
+    6033 PUSHENVACC1 
+    6034 GETVECTITEM 
+    6035 ADDINT 
+    6036 PUSHACC1 
+    6037 PUSHENVACC1 
+    6038 SETVECTITEM 
+    6039 POP 1
+    6041 ACC1 
+    6042 OFFSETINT 1
+    6044 ASSIGN 1
+    6046 ACC0 
+    6047 PUSHACC2 
+    6048 LEINT 
+    6049 BRANCHIF 6024
+    6051 CONST0 
+    6052 RETURN 3
+    6054 ENVACC1 
+    6055 GETFIELD0 
+    6056 OFFSETINT 1
+    6058 PUSHENVACC1 
+    6059 SETFIELD0 
+    6060 ENVACC1 
+    6061 GETFIELD0 
+    6062 PUSHGETGLOBALFIELD Pervasives, 14
+    6065 APPLY1 
+    6066 PUSHGETGLOBALFIELD Digest, 0
+    6069 APPLY1 
+    6070 PUSHCONSTINT 22
+    6072 PUSHCONST3 
+    6073 PUSHACC2 
+    6074 C_CALL2 string_get
+    6076 LSLINT 
+    6077 PUSHCONSTINT 16
+    6079 PUSHCONST2 
+    6080 PUSHACC3 
+    6081 C_CALL2 string_get
+    6083 LSLINT 
+    6084 PUSHCONSTINT 8
+    6086 PUSHCONST1 
+    6087 PUSHACC4 
+    6088 C_CALL2 string_get
+    6090 LSLINT 
+    6091 PUSHCONST0 
+    6092 PUSHACC4 
+    6093 C_CALL2 string_get
+    6095 ADDINT 
+    6096 ADDINT 
+    6097 XORINT 
+    6098 RETURN 2
+    6100 ACC0 
+    6101 MAKEBLOCK1 0
+    6103 PUSHACC0 
+    6104 CLOSURE 1, 6054
+    6107 PUSHCONST0 
+    6108 PUSHCONSTINT 54
+    6110 PUSH 
+    6111 BRANCH 6125
+    6113 CHECK_SIGNALS 
+    6114 CONST0 
+    6115 PUSHACC3 
+    6116 APPLY1 
+    6117 PUSHACC2 
+    6118 PUSHENVACC1 
+    6119 SETVECTITEM 
+    6120 ACC1 
+    6121 OFFSETINT 1
+    6123 ASSIGN 1
+    6125 ACC0 
+    6126 PUSHACC2 
+    6127 LEINT 
+    6128 BRANCHIF 6113
+    6130 CONST0 
+    6131 POP 2
+    6133 CONST0 
+    6134 PUSHENVACC2 
+    6135 SETFIELD0 
+    6136 RETURN 3
+    6138 ACC0 
+    6139 PUSHCONST0 
+    6140 PUSHENVACC1 
+    6141 APPLY1 
+    6142 C_CALL2 mul_float
+    6144 RETURN 1
+    6146 CONSTINT 1073741823
+    6148 PUSHACC1 
+    6149 GTINT 
+    6150 BRANCHIF 6157
+    6152 CONST0 
+    6153 PUSHACC1 
+    6154 LEINT 
+    6155 BRANCHIFNOT 6164
+    6157 GETGLOBAL "Random.int"
+    6159 PUSHGETGLOBALFIELD Pervasives, 2
+    6162 APPTERM1 2
+    6164 ACC0 
+    6165 PUSHACC1 
+    6166 PUSHACC2 
+    6167 PUSHCONSTINT 1073741823
+    6169 DIVINT 
+    6170 MULINT 
+    6171 PUSHENVACC1 
+    6172 APPLY1 
+    6173 MODINT 
+    6174 RETURN 1
+    6176 GETGLOBAL 1073741824
+    6178 PUSHCONST0 
+    6179 PUSHENVACC1 
+    6180 APPLY1 
+    6181 C_CALL1 float_of_int
+    6183 PUSHCONST0 
+    6184 PUSHENVACC1 
+    6185 APPLY1 
+    6186 C_CALL1 float_of_int
+    6188 PUSHCONST0 
+    6189 PUSHENVACC1 
+    6190 APPLY1 
+    6191 C_CALL1 float_of_int
+    6193 PUSHACC3 
+    6194 PUSHACC1 
+    6195 PUSHACC5 
+    6196 PUSHACC4 
+    6197 PUSHACC7 
+    6198 PUSHACC7 
+    6199 C_CALL2 div_float
+    6201 C_CALL2 add_float
+    6203 C_CALL2 div_float
+    6205 C_CALL2 add_float
+    6207 C_CALL2 div_float
+    6209 RETURN 5
+    6211 CONSTINT 55
+    6213 PUSHENVACC2 
+    6214 GETFIELD0 
+    6215 OFFSETINT 1
+    6217 MODINT 
+    6218 PUSHENVACC2 
+    6219 SETFIELD0 
+    6220 ENVACC2 
+    6221 GETFIELD0 
+    6222 PUSHENVACC1 
+    6223 GETVECTITEM 
+    6224 PUSHCONSTINT 55
+    6226 PUSHENVACC2 
+    6227 GETFIELD0 
+    6228 OFFSETINT 24
+    6230 MODINT 
+    6231 PUSHENVACC1 
+    6232 GETVECTITEM 
+    6233 ADDINT 
+    6234 PUSHACC0 
+    6235 PUSHENVACC2 
+    6236 GETFIELD0 
+    6237 PUSHENVACC1 
+    6238 SETVECTITEM 
+    6239 CONSTINT 1073741823
+    6241 PUSHACC1 
+    6242 ANDINT 
+    6243 RETURN 2
+    6245 CONSTINT 440266690
+    6247 PUSHCONSTINT 124177607
+    6249 PUSHCONSTINT 414576093
+    6251 PUSHCONSTINT 180326017
+    6253 PUSHCONSTINT 33747835
+    6255 PUSHCONSTINT 896816596
+    6257 PUSHCONSTINT 21528564
+    6259 PUSHCONSTINT 414383108
+    6261 PUSHCONSTINT 514922558
+    6263 PUSHCONSTINT 979459837
+    6265 PUSHCONSTINT 146577263
+    6267 PUSHCONSTINT 714526560
+    6269 PUSHCONSTINT 187230644
+    6271 PUSHCONSTINT 22990936
+    6273 PUSHCONSTINT 310632349
+    6275 PUSHCONSTINT 781847598
+    6277 PUSHCONSTINT 854580894
+    6279 PUSHCONSTINT 804670393
+    6281 PUSHCONSTINT 268309077
+    6283 PUSHCONSTINT 4136554
+    6285 PUSHCONSTINT 567327260
+    6287 PUSHCONSTINT 768795410
+    6289 PUSHCONSTINT 868098973
+    6291 PUSHCONSTINT 462134267
+    6293 PUSHCONSTINT 32881167
+    6295 PUSHCONSTINT 708896334
+    6297 PUSHCONSTINT 572927557
+    6299 PUSHCONSTINT 933858406
+    6301 PUSHCONSTINT 965168955
+    6303 PUSHCONSTINT 233350272
+    6305 PUSHCONSTINT 878960411
+    6307 PUSHCONSTINT 971004788
+    6309 PUSHCONSTINT 762624501
+    6311 PUSHCONSTINT 796925167
+    6313 PUSHCONSTINT 206134737
+    6315 PUSHCONSTINT 281896889
+    6317 PUSHCONSTINT 814302728
+    6319 PUSHCONSTINT 477485839
+    6321 PUSHCONSTINT 998499212
+    6323 PUSHCONSTINT 473370118
+    6325 PUSHCONSTINT 66770770
+    6327 PUSHCONSTINT 337696531
+    6329 PUSHCONSTINT 848741663
+    6331 PUSHCONSTINT 71648846
+    6333 PUSHCONSTINT 869261341
+    6335 PUSHCONSTINT 951240904
+    6337 PUSHCONSTINT 147054819
+    6339 PUSHCONSTINT 486882977
+    6341 PUSHCONSTINT 552627506
+    6343 PUSHCONSTINT 615350359
+    6345 PUSHCONSTINT 1023641486
+    6347 PUSHCONSTINT 9858203
+    6349 PUSHCONSTINT 764306064
+    6351 PUSHCONSTINT 1051173471
+    6353 PUSHCONSTINT 561073064
+    6355 MAKEBLOCK 55, 0
+    6358 PUSHCONST0 
+    6359 MAKEBLOCK1 0
+    6361 PUSHACC0 
+    6362 PUSHACC2 
+    6363 CLOSURE 2, 6211
+    6366 PUSHACC0 
+    6367 CLOSURE 1, 6176
+    6370 PUSHACC1 
+    6371 CLOSUREREC 1, 5991
+    6375 ACC0 
+    6376 CLOSURE 1, 6146
+    6379 PUSHACC2 
+    6380 CLOSURE 1, 6138
+    6383 PUSHACC5 
+    6384 PUSHACC7 
+    6385 CLOSURE 2, 6100
+    6388 PUSHACC0 
+    6389 PUSHACC 8
+    6391 CLOSURE 2, 6012
+    6394 PUSHACC1 
+    6395 CLOSURE 1, 6006
+    6398 PUSHACC3 
+    6399 PUSHACC5 
+    6400 PUSHACC 9
+    6402 PUSHACC3 
+    6403 PUSHACC5 
+    6404 PUSHACC7 
+    6405 MAKEBLOCK 6, 0
+    6408 POP 10
+    6410 SETGLOBAL Random
+    6412 BRANCH 8038
+    6414 RESTART 
+    6415 GRAB 1
+    6417 ACC1 
+    6418 BRANCHIFNOT 6441
+    6420 ACC1 
+    6421 GETFIELD0 
+    6422 PUSHACC2 
+    6423 GETFIELD1 
+    6424 PUSHACC1 
+    6425 PUSHACC3 
+    6426 EQ 
+    6427 BRANCHIFNOT 6432
+    6429 ACC0 
+    6430 RETURN 4
+    6432 ACC0 
+    6433 PUSHACC3 
+    6434 PUSHOFFSETCLOSURE0 
+    6435 APPLY2 
+    6436 PUSHACC2 
+    6437 MAKEBLOCK2 0
+    6439 POP 2
+    6441 RETURN 2
+    6443 RESTART 
+    6444 GRAB 1
+    6446 CONST0 
+    6447 PUSHACC2 
+    6448 GTINT 
+    6449 BRANCHIFNOT 6512
+    6451 CONST0 
+    6452 PUSHENVACC2 
+    6453 GETFIELD0 
+    6454 GTINT 
+    6455 BRANCHIFNOT 6512
+    6457 ENVACC2 
+    6458 GETFIELD0 
+    6459 PUSHGETGLOBALFIELD Random, 4
+    6462 APPLY1 
+    6463 PUSHACC0 
+    6464 PUSHENVACC1 
+    6465 GETFIELD0 
+    6466 C_CALL2 array_get_addr
+    6468 PUSHENVACC 5
+    6470 APPLY1 
+    6471 BRANCHIF 6482
+    6473 ACC0 
+    6474 PUSHENVACC 4
+    6476 APPLY1 
+    6477 ACC2 
+    6478 PUSHACC2 
+    6479 PUSHOFFSETCLOSURE0 
+    6480 APPTERM2 5
+    6482 PUSHTRAP 6496
+    6484 ACC5 
+    6485 PUSHACC5 
+    6486 PUSHENVACC1 
+    6487 GETFIELD0 
+    6488 C_CALL2 array_get_addr
+    6490 PUSHENVACC 7
+    6492 APPLY2 
+    6493 POPTRAP 
+    6494 RETURN 3
+    6496 PUSHENVACC 6
+    6498 PUSHACC1 
+    6499 GETFIELD0 
+    6500 EQ 
+    6501 BRANCHIFNOT 6510
+    6503 ACC3 
+    6504 OFFSETINT -1
+    6506 PUSHACC3 
+    6507 PUSHOFFSETCLOSURE0 
+    6508 APPTERM2 6
+    6510 ACC0 
+    6511 RAISE 
+    6512 ACC0 
+    6513 PUSHENVACC3 
+    6514 APPLY1 
+    6515 ACC0 
+    6516 RETURN 2
+    6518 RESTART 
+    6519 GRAB 1
+    6521 ACC1 
+    6522 BRANCHIFNOT 6534
+    6524 ACC0 
+    6525 PUSHACC2 
+    6526 GETFIELD0 
+    6527 APPLY1 
+    6528 ACC1 
+    6529 GETFIELD1 
+    6530 PUSHACC1 
+    6531 PUSHOFFSETCLOSURE0 
+    6532 APPTERM2 4
+    6534 RETURN 2
+    6536 CONST0 
+    6537 PUSHENVACC1 
+    6538 OFFSETINT -1
+    6540 PUSH 
+    6541 BRANCH 6567
+    6543 CHECK_SIGNALS 
+    6544 ENVACC2 
+    6545 PUSHACC2 
+    6546 PUSHACC4 
+    6547 C_CALL2 array_get
+    6549 EQ 
+    6550 BRANCHIFNOT 6556
+    6552 CONSTINT 46
+    6554 BRANCH 6558
+    6556 CONSTINT 42
+    6558 PUSHGETGLOBALFIELD Pervasives, 20
+    6561 APPLY1 
+    6562 ACC1 
+    6563 OFFSETINT 1
+    6565 ASSIGN 1
+    6567 ACC0 
+    6568 PUSHACC2 
+    6569 LEINT 
+    6570 BRANCHIF 6543
+    6572 CONST0 
+    6573 POP 2
+    6575 CONST0 
+    6576 PUSHGETGLOBALFIELD Pervasives, 25
+    6579 APPTERM1 2
+    6581 ENVACC3 
+    6582 GETFIELD0 
+    6583 PUSHENVACC 4
+    6585 APPLY1 
+    6586 PUSHENVACC2 
+    6587 PUSHENVACC1 
+    6588 CLOSURE 2, 6536
+    6591 PUSHGETGLOBALFIELD List, 9
+    6594 APPTERM2 3
+    6596 ACC0 
+    6597 GETFIELD1 
+    6598 RETURN 1
+    6600 RESTART 
+    6601 GRAB 1
+    6603 ACC1 
+    6604 GETFIELD0 
+    6605 PUSHACC1 
+    6606 GETFIELD0 
+    6607 LEINT 
+    6608 RETURN 2
+    6610 ACC0 
+    6611 PUSHACC1 
+    6612 PUSHENVACC1 
+    6613 APPLY1 
+    6614 MAKEBLOCK2 0
+    6616 RETURN 1
+    6618 ACC0 
+    6619 PUSHENVACC1 
+    6620 CLOSURE 1, 6610
+    6623 PUSHGETGLOBALFIELD List, 10
+    6626 APPLY2 
+    6627 PUSH 
+    6628 CLOSURE 0, 6601
+    6631 PUSHGETGLOBALFIELD Sort, 0
+    6634 APPLY2 
+    6635 PUSH 
+    6636 CLOSURE 0, 6596
+    6639 PUSHGETGLOBALFIELD List, 10
+    6642 APPTERM2 3
+    6644 ENVACC3 
+    6645 GETFIELD0 
+    6646 VECTLENGTH 
+    6647 PUSHENVACC 4
+    6649 GETFIELD0 
+    6650 PUSHCONST0 
+    6651 PUSHENVACC 8
+    6653 APPLY1 
+    6654 PUSHENVACC2 
+    6655 GETFIELD0 
+    6656 PUSHGETGLOBALFIELD List, 0
+    6659 APPLY1 
+    6660 PUSHENVACC 7
+    6662 GETFIELD0 
+    6663 PUSHENVACC 6
+    6665 GETFIELD0 
+    6666 PUSHENVACC1 
+    6667 GETFIELD0 
+    6668 PUSHENVACC 5
+    6670 GETFIELD0 
+    6671 MAKEBLOCK 8, 0
+    6674 RETURN 1
+    6676 ACC0 
+    6677 PUSHENVACC1 
+    6678 APPLY1 
+    6679 PUSHACC0 
+    6680 OFFSETINT -1
+    6682 PUSHENVACC2 
+    6683 C_CALL2 array_get_addr
+    6685 OFFSETINT 1
+    6687 PUSHACC1 
+    6688 OFFSETINT -1
+    6690 PUSHENVACC2 
+    6691 C_CALL3 array_set_addr
+    6693 RETURN 2
+    6695 CONST0 
+    6696 PUSHCONSTINT 32
+    6698 C_CALL2 make_vect
+    6700 PUSHENVACC1 
+    6701 GETFIELD0 
+    6702 PUSHACC1 
+    6703 PUSHENVACC2 
+    6704 CLOSURE 2, 6676
+    6707 PUSHGETGLOBALFIELD List, 9
+    6710 APPLY2 
+    6711 ACC0 
+    6712 RETURN 2
+    6714 RESTART 
+    6715 GRAB 1
+    6717 ACC1 
+    6718 PUSHENVACC1 
+    6719 APPLY1 
+    6720 PUSHACC1 
+    6721 PUSHACC1 
+    6722 GETFIELD1 
+    6723 PUSHACC2 
+    6724 GETFIELD0 
+    6725 PUSHCONST0 
+    6726 PUSHACC5 
+    6727 C_CALL2 array_get_addr
+    6729 C_CALL2 array_get_addr
+    6731 C_CALL2 array_get_addr
+    6733 APPTERM1 4
+    6735 ACC0 
+    6736 GETFIELD0 
+    6737 C_CALL1 obj_dup
+    6739 PUSHENVACC1 
+    6740 PUSHACC1 
+    6741 PUSHENVACC2 
+    6742 APPLY2 
+    6743 ACC1 
+    6744 GETFIELD2 
+    6745 PUSHACC1 
+    6746 PUSHENVACC3 
+    6747 APPLY2 
+    6748 ACC0 
+    6749 RETURN 2
+    6751 RESTART 
+    6752 GRAB 1
+    6754 ACC1 
+    6755 GETFIELD 7
+    6757 PUSHCONST0 
+    6758 PUSHACC1 
+    6759 NEQ 
+    6760 BRANCHIFNOT 6767
+    6762 ACC0 
+    6763 PUSHACC2 
+    6764 PUSHENVACC1 
+    6765 APPTERM2 5
+    6767 RETURN 3
+    6769 ACC0 
+    6770 GETFIELD0 
+    6771 PUSHENVACC1 
+    6772 C_CALL2 obj_block
+    6774 PUSHACC1 
+    6775 GETFIELD1 
+    6776 PUSHCONST0 
+    6777 PUSHACC2 
+    6778 C_CALL3 array_unsafe_set
+    6780 ENVACC2 
+    6781 PUSHACC1 
+    6782 PUSHENVACC3 
+    6783 APPLY2 
+    6784 ACC0 
+    6785 RETURN 2
+    6787 ACC0 
+    6788 GETFIELD0 
+    6789 PUSHENVACC3 
+    6790 GETFIELD0 
+    6791 ADDINT 
+    6792 OFFSETINT -1
+    6794 PUSHENVACC3 
+    6795 SETFIELD0 
+    6796 ENVACC1 
+    6797 GETFIELD0 
+    6798 BRANCHIFNOT 6804
+    6800 ACC0 
+    6801 GETFIELD1 
+    6802 PUSHENVACC2 
+    6803 APPLY1 
+    6804 ACC0 
+    6805 GETFIELD 7
+    6807 PUSHGETGLOBALFIELD List, 4
+    6810 APPLY1 
+    6811 PUSHACC1 
+    6812 SETFIELD 7
+    6814 RETURN 1
+    6816 ACC0 
+    6817 PUSHENVACC1 
+    6818 APPLY1 
+    6819 PUSHENVACC 4
+    6821 GETFIELD2 
+    6822 PUSHACC1 
+    6823 PUSHACC3 
+    6824 PUSHENVACC2 
+    6825 GETFIELD1 
+    6826 APPLY3 
+    6827 PUSHENVACC 4
+    6829 SETFIELD2 
+    6830 ENVACC4 
+    6831 GETFIELD3 
+    6832 PUSHCONST1 
+    6833 PUSHACC2 
+    6834 PUSHENVACC3 
+    6835 GETFIELD1 
+    6836 APPLY3 
+    6837 PUSHENVACC 4
+    6839 SETFIELD3 
+    6840 RETURN 2
+    6842 CONST0 
+    6843 PUSHENVACC 4
+    6845 APPLY1 
+    6846 PUSHACC1 
+    6847 PUSHACC1 
+    6848 PUSHENVACC3 
+    6849 PUSHENVACC2 
+    6850 PUSHENVACC1 
+    6851 CLOSURE 4, 6816
+    6854 PUSHGETGLOBALFIELD List, 9
+    6857 APPLY2 
+    6858 ACC0 
+    6859 RETURN 2
+    6861 RESTART 
+    6862 GRAB 1
+    6864 ACC0 
+    6865 GETFIELD 7
+    6867 PUSHACC2 
+    6868 MAKEBLOCK2 0
+    6870 PUSHACC1 
+    6871 SETFIELD 7
+    6873 RETURN 2
+    6875 ENVACC1 
+    6876 PUSHENVACC3 
+    6877 PUSH 
+    6878 BRANCH 6895
+    6880 CHECK_SIGNALS 
+    6881 ACC1 
+    6882 PUSHENVACC2 
+    6883 GETVECTITEM 
+    6884 PUSHENVACC 4
+    6886 PUSHACC3 
+    6887 ADDINT 
+    6888 PUSHACC4 
+    6889 SETVECTITEM 
+    6890 ACC1 
+    6891 OFFSETINT 1
+    6893 ASSIGN 1
+    6895 ACC0 
+    6896 PUSHACC2 
+    6897 LEINT 
+    6898 BRANCHIF 6880
+    6900 CONST0 
+    6901 RETURN 3
+    6903 ENVACC2 
+    6904 GETFIELD0 
+    6905 PUSHENVACC2 
+    6906 GETFIELD2 
+    6907 GETFIELD0 
+    6908 OFFSETINT -1
+    6910 PUSHENVACC3 
+    6911 GETFIELD0 
+    6912 OFFSETINT -1
+    6914 PUSHACC1 
+    6915 PUSHACC1 
+    6916 SUBINT 
+    6917 PUSHACC0 
+    6918 PUSHACC3 
+    6919 PUSHACC5 
+    6920 PUSHENVACC1 
+    6921 CLOSURE 4, 6875
+    6924 RETURN 5
+    6926 RESTART 
+    6927 GRAB 1
+    6929 CONST0 
+    6930 ACC1 
+    6931 PUSHACC1 
+    6932 PUSHENVACC1 
+    6933 CLOSURE 3, 6903
+    6936 RETURN 2
+    6938 RESTART 
+    6939 GRAB 1
+    6941 ACC0 
+    6942 GETFIELD 6
+    6944 PUSHACC2 
+    6945 PUSHENVACC1 
+    6946 GETFIELD2 
+    6947 APPTERM2 4
+    6949 RESTART 
+    6950 GRAB 1
+    6952 ACC0 
+    6953 PUSHENVACC2 
+    6954 APPLY1 
+    6955 PUSHACC1 
+    6956 GETFIELD 6
+    6958 PUSHACC1 
+    6959 PUSHACC4 
+    6960 PUSHENVACC1 
+    6961 GETFIELD1 
+    6962 APPLY3 
+    6963 PUSHACC2 
+    6964 SETFIELD 6
+    6966 ACC0 
+    6967 RETURN 3
+    6969 ACC0 
+    6970 GETFIELD0 
+    6971 PUSHACC0 
+    6972 OFFSETINT 1
+    6974 PUSHACC2 
+    6975 SETFIELD0 
+    6976 ACC0 
+    6977 RETURN 2
+    6979 RESTART 
+    6980 GRAB 1
+    6982 CONST0 
+    6983 PUSHACC1 
+    6984 PUSHACC3 
+    6985 GETFIELD1 
+    6986 APPTERM2 4
+    6988 RESTART 
+    6989 GRAB 1
+    6991 ENVACC1 
+    6992 GETFIELD 4
+    6994 PUSHACC1 
+    6995 GETFIELD0 
+    6996 PUSHGETGLOBALFIELD List, 23
+    6999 APPLY2 
+    7000 BRANCHIFNOT 7005
+    7002 ACC1 
+    7003 RETURN 2
+    7005 ACC1 
+    7006 PUSHACC1 
+    7007 MAKEBLOCK2 0
+    7009 RETURN 2
+    7011 RESTART 
+    7012 GRAB 1
+    7014 ACC0 
+    7015 PUSHENVACC2 
+    7016 GETFIELD 6
+    7018 PUSHACC3 
+    7019 PUSHENVACC1 
+    7020 GETFIELD2 
+    7021 APPLY2 
+    7022 PUSHACC3 
+    7023 PUSHENVACC1 
+    7024 GETFIELD1 
+    7025 APPTERM3 5
+    7027 ACC0 
+    7028 GETFIELD 4
+    7030 PUSHGETGLOBALFIELD List, 1
+    7033 APPLY1 
+    7034 PUSHACC1 
+    7035 GETFIELD 4
+    7037 PUSHGETGLOBALFIELD List, 2
+    7040 APPLY1 
+    7041 PUSHACC2 
+    7042 SETFIELD 4
+    7044 ACC0 
+    7045 GETFIELD 5
+    7047 PUSHACC1 
+    7048 GETFIELD3 
+    7049 PUSHACC3 
+    7050 PUSHENVACC1 
+    7051 CLOSURE 2, 7012
+    7054 PUSHGETGLOBALFIELD List, 12
+    7057 APPLY3 
+    7058 PUSHACC2 
+    7059 SETFIELD 6
+    7061 ACC0 
+    7062 GETFIELD0 
+    7063 PUSHACC2 
+    7064 SETFIELD2 
+    7065 ACC0 
+    7066 GETFIELD1 
+    7067 PUSHACC2 
+    7068 SETFIELD3 
+    7069 ACC0 
+    7070 GETFIELD2 
+    7071 PUSHACC2 
+    7072 GETFIELD 5
+    7074 PUSHACC2 
+    7075 CLOSURE 1, 6989
+    7078 PUSHGETGLOBALFIELD List, 13
+    7081 APPLY3 
+    7082 PUSHACC2 
+    7083 SETFIELD 5
+    7085 RETURN 2
+    7087 RESTART 
+    7088 GRAB 1
+    7090 ENVACC1 
+    7091 PUSHACC1 
+    7092 GETFIELD0 
+    7093 PUSHGETGLOBALFIELD List, 23
+    7096 APPLY2 
+    7097 BRANCHIFNOT 7102
+    7099 ACC1 
+    7100 RETURN 2
+    7102 ACC1 
+    7103 PUSHACC1 
+    7104 MAKEBLOCK2 0
+    7106 RETURN 2
+    7108 RESTART 
+    7109 GRAB 1
+    7111 ENVACC3 
+    7112 GETFIELD0 
+    7113 PUSHACC2 
+    7114 PUSHACC2 
+    7115 PUSHENVACC1 
+    7116 GETFIELD1 
+    7117 APPLY3 
+    7118 PUSHENVACC3 
+    7119 SETFIELD0 
+    7120 ENVACC4 
+    7121 GETFIELD0 
+    7122 PUSHCONST0 
+    7123 PUSHACC3 
+    7124 PUSHENVACC2 
+    7125 GETFIELD1 
+    7126 APPLY3 
+    7127 PUSHENVACC 4
+    7129 SETFIELD0 
+    7130 RETURN 2
+    7132 ACC0 
+    7133 PUSHENVACC 4
+    7135 PUSHENVACC3 
+    7136 APPLY2 
+    7137 PUSHENVACC 5
+    7139 GETFIELD0 
+    7140 PUSHACC1 
+    7141 PUSHACC3 
+    7142 PUSHENVACC1 
+    7143 GETFIELD1 
+    7144 APPLY3 
+    7145 PUSHENVACC 5
+    7147 SETFIELD0 
+    7148 ENVACC 6
+    7150 GETFIELD0 
+    7151 PUSH 
+    7152 PUSHTRAP 7163
+    7154 ENVACC4 
+    7155 GETFIELD3 
+    7156 PUSHACC6 
+    7157 PUSHENVACC2 
+    7158 GETFIELD2 
+    7159 APPLY2 
+    7160 POPTRAP 
+    7161 BRANCH 7177
+    7163 PUSHGETGLOBAL Not_found
+    7165 PUSHACC1 
+    7166 GETFIELD0 
+    7167 EQ 
+    7168 BRANCHIFNOT 7173
+    7170 CONST1 
+    7171 BRANCH 7175
+    7173 ACC0 
+    7174 RAISE 
+    7175 POP 1
+    7177 PUSHACC2 
+    7178 PUSHENVACC2 
+    7179 GETFIELD1 
+    7180 APPLY3 
+    7181 PUSHENVACC 6
+    7183 SETFIELD0 
+    7184 RETURN 2
+    7186 RESTART 
+    7187 GRAB 3
+    7189 ACC2 
+    7190 PUSHACC1 
+    7191 PUSHENVACC 4
+    7193 APPLY1 
+    7194 PUSHGETGLOBALFIELD List, 10
+    7197 APPLY2 
+    7198 PUSHACC1 
+    7199 GETFIELD 4
+    7201 PUSHACC3 
+    7202 PUSHACC2 
+    7203 PUSHACC4 
+    7204 GETFIELD 6
+    7206 PUSHACC5 
+    7207 GETFIELD 5
+    7209 PUSHACC6 
+    7210 GETFIELD3 
+    7211 PUSHACC7 
+    7212 GETFIELD2 
+    7213 MAKEBLOCK 6, 0
+    7216 MAKEBLOCK2 0
+    7218 PUSHACC2 
+    7219 SETFIELD 4
+    7221 ENVACC1 
+    7222 GETFIELD0 
+    7223 PUSHACC2 
+    7224 SETFIELD 6
+    7226 ENVACC2 
+    7227 GETFIELD0 
+    7228 MAKEBLOCK1 0
+    7230 PUSHENVACC3 
+    7231 GETFIELD0 
+    7232 MAKEBLOCK1 0
+    7234 PUSHACC6 
+    7235 PUSHACC1 
+    7236 PUSHACC3 
+    7237 PUSHACC6 
+    7238 PUSHENVACC 4
+    7240 PUSHENVACC3 
+    7241 PUSHENVACC2 
+    7242 CLOSURE 6, 7132
+    7245 PUSHGETGLOBALFIELD List, 9
+    7248 APPLY2 
+    7249 ACC2 
+    7250 PUSHACC6 
+    7251 PUSHACC2 
+    7252 PUSHACC4 
+    7253 PUSHENVACC3 
+    7254 PUSHENVACC2 
+    7255 CLOSURE 4, 7109
+    7258 PUSHGETGLOBALFIELD List, 14
+    7261 APPLY3 
+    7262 ACC1 
+    7263 GETFIELD0 
+    7264 PUSHACC4 
+    7265 SETFIELD2 
+    7266 ACC0 
+    7267 GETFIELD0 
+    7268 PUSHACC4 
+    7269 SETFIELD3 
+    7270 CONST0 
+    7271 PUSHACC4 
+    7272 GETFIELD 5
+    7274 PUSHACC4 
+    7275 CLOSURE 1, 7088
+    7278 PUSHGETGLOBALFIELD List, 13
+    7281 APPLY3 
+    7282 PUSHACC4 
+    7283 SETFIELD 5
+    7285 RETURN 7
+    7287 RESTART 
+    7288 GRAB 1
+    7290 PUSHTRAP 7303
+    7292 ACC4 
+    7293 GETFIELD 5
+    7295 PUSHACC6 
+    7296 PUSHGETGLOBALFIELD List, 29
+    7299 APPLY2 
+    7300 POPTRAP 
+    7301 RETURN 2
+    7303 PUSHGETGLOBAL Not_found
+    7305 PUSHACC1 
+    7306 GETFIELD0 
+    7307 EQ 
+    7308 BRANCHIFNOT 7325
+    7310 ACC2 
+    7311 PUSHENVACC1 
+    7312 APPLY1 
+    7313 PUSHACC0 
+    7314 GETFIELD1 
+    7315 PUSHACC1 
+    7316 GETFIELD0 
+    7317 PUSHACC4 
+    7318 GETFIELD1 
+    7319 C_CALL2 array_get_addr
+    7321 C_CALL2 array_get
+    7323 RETURN 4
+    7325 ACC0 
+    7326 RAISE 
+    7327 RESTART 
+    7328 GRAB 2
+    7330 ENVACC3 
+    7331 OFFSETREF 1
+    7333 ACC0 
+    7334 GETFIELD3 
+    7335 PUSHACC2 
+    7336 PUSHENVACC1 
+    7337 GETFIELD2 
+    7338 APPLY2 
+    7339 BRANCHIFNOT 7347
+    7341 ACC2 
+    7342 PUSHACC2 
+    7343 PUSHACC2 
+    7344 PUSHENVACC2 
+    7345 APPTERM3 6
+    7347 ACC0 
+    7348 GETFIELD 5
+    7350 PUSHACC3 
+    7351 PUSHACC3 
+    7352 MAKEBLOCK2 0
+    7354 MAKEBLOCK2 0
+    7356 PUSHACC1 
+    7357 SETFIELD 5
+    7359 RETURN 3
+    7361 RESTART 
+    7362 GRAB 1
+    7364 PUSHTRAP 7375
+    7366 ACC4 
+    7367 GETFIELD2 
+    7368 PUSHACC6 
+    7369 PUSHENVACC2 
+    7370 GETFIELD2 
+    7371 APPLY2 
+    7372 POPTRAP 
+    7373 RETURN 2
+    7375 PUSHGETGLOBAL Not_found
+    7377 PUSHACC1 
+    7378 GETFIELD0 
+    7379 EQ 
+    7380 BRANCHIFNOT 7406
+    7382 CONST0 
+    7383 PUSHENVACC1 
+    7384 APPLY1 
+    7385 PUSHACC2 
+    7386 GETFIELD2 
+    7387 PUSHACC1 
+    7388 PUSHACC5 
+    7389 PUSHENVACC2 
+    7390 GETFIELD1 
+    7391 APPLY3 
+    7392 PUSHACC3 
+    7393 SETFIELD2 
+    7394 ACC2 
+    7395 GETFIELD3 
+    7396 PUSHCONST1 
+    7397 PUSHACC2 
+    7398 PUSHENVACC3 
+    7399 GETFIELD1 
+    7400 APPLY3 
+    7401 PUSHACC3 
+    7402 SETFIELD3 
+    7403 ACC0 
+    7404 RETURN 4
+    7406 ACC0 
+    7407 RAISE 
+    7408 RESTART 
+    7409 GRAB 2
+    7411 ACC1 
+    7412 PUSHENVACC1 
+    7413 APPLY1 
+    7414 PUSHACC0 
+    7415 GETFIELD0 
+    7416 PUSHACC0 
+    7417 OFFSETINT 1
+    7419 PUSHACC3 
+    7420 PUSHENVACC 4
+    7422 APPLY2 
+    7423 ACC0 
+    7424 PUSHACC3 
+    7425 GETFIELD1 
+    7426 C_CALL2 array_get_addr
+    7428 PUSHENVACC2 
+    7429 PUSHACC1 
+    7430 EQ 
+    7431 BRANCHIFNOT 7444
+    7433 CONST0 
+    7434 PUSHENVACC3 
+    7435 APPLY1 
+    7436 ASSIGN 0
+    7438 ACC0 
+    7439 PUSHACC2 
+    7440 PUSHACC5 
+    7441 GETFIELD1 
+    7442 C_CALL3 array_set_addr
+    7444 ACC5 
+    7445 PUSHACC3 
+    7446 GETFIELD1 
+    7447 PUSHACC2 
+    7448 C_CALL3 array_set
+    7450 RETURN 6
+    7452 RESTART 
+    7453 GRAB 1
+    7455 ACC0 
+    7456 GETFIELD1 
+    7457 VECTLENGTH 
+    7458 PUSHACC0 
+    7459 PUSHACC3 
+    7460 GTINT 
+    7461 BRANCHIFNOT 7487
+    7463 ENVACC1 
+    7464 PUSHACC3 
+    7465 C_CALL2 make_vect
+    7467 PUSH 
+    7468 PUSH_RETADDR 7482
+    7470 ACC4 
+    7471 PUSHCONST0 
+    7472 PUSHACC5 
+    7473 PUSHCONST0 
+    7474 PUSHACC 9
+    7476 GETFIELD1 
+    7477 PUSHGETGLOBALFIELD Array, 8
+    7480 APPLY 5
+    7482 ACC0 
+    7483 PUSHACC3 
+    7484 SETFIELD1 
+    7485 POP 1
+    7487 RETURN 3
+    7489 ENVACC 5
+    7491 OFFSETREF 1
+    7493 CONST0 
+    7494 PUSHENVACC2 
+    7495 GETFIELD0 
+    7496 PUSHCONST0 
+    7497 PUSHCONST0 
+    7498 PUSHENVACC 4
+    7500 GETFIELD0 
+    7501 PUSHENVACC3 
+    7502 GETFIELD0 
+    7503 PUSH 
+    7504 ATOM0 
+    7505 PUSHENVACC1 
+    7506 MAKEBLOCK 8, 0
+    7509 RETURN 1
+    7511 RESTART 
+    7512 GRAB 1
+    7514 ACC1 
+    7515 PUSHACC1 
+    7516 C_CALL2 compare
+    7518 RETURN 2
+    7520 RESTART 
+    7521 GRAB 1
+    7523 ACC1 
+    7524 PUSHACC1 
+    7525 C_CALL2 compare
+    7527 RETURN 2
+    7529 RESTART 
+    7530 GRAB 1
+    7532 ACC1 
+    7533 PUSHACC1 
+    7534 C_CALL2 compare
+    7536 RETURN 2
+    7538 PUSHTRAP 7549
+    7540 ACC4 
+    7541 PUSHENVACC1 
+    7542 PUSHGETGLOBALFIELD Hashtbl, 3
+    7545 APPLY2 
+    7546 POPTRAP 
+    7547 RETURN 1
+    7549 PUSHGETGLOBAL Not_found
+    7551 PUSHACC1 
+    7552 GETFIELD0 
+    7553 EQ 
+    7554 BRANCHIFNOT 7569
+    7556 CONST0 
+    7557 PUSHENVACC2 
+    7558 APPLY1 
+    7559 PUSHACC0 
+    7560 PUSHACC3 
+    7561 PUSHENVACC1 
+    7562 PUSHGETGLOBALFIELD Hashtbl, 2
+    7565 APPLY3 
+    7566 ACC0 
+    7567 RETURN 3
+    7569 ACC0 
+    7570 RAISE 
+    7571 ENVACC2 
+    7572 GETFIELD0 
+    7573 PUSHENVACC2 
+    7574 GETFIELD0 
+    7575 PUSHENVACC1 
+    7576 APPLY1 
+    7577 PUSHENVACC2 
+    7578 SETFIELD0 
+    7579 ACC0 
+    7580 RETURN 2
+    7582 ENVACC1 
+    7583 PUSHACC1 
+    7584 VECTLENGTH 
+    7585 OFFSETINT -1
+    7587 PUSH 
+    7588 BRANCH 7606
+    7590 CHECK_SIGNALS 
+    7591 ACC1 
+    7592 PUSHACC3 
+    7593 C_CALL2 array_get_addr
+    7595 PUSHENVACC2 
+    7596 APPLY1 
+    7597 PUSHACC2 
+    7598 PUSHACC4 
+    7599 C_CALL3 array_set_addr
+    7601 ACC1 
+    7602 OFFSETINT 1
+    7604 ASSIGN 1
+    7606 ACC0 
+    7607 PUSHACC2 
+    7608 LEINT 
+    7609 BRANCHIF 7590
+    7611 CONST0 
+    7612 RETURN 3
+    7614 ENVACC4 
+    7615 PUSHACC1 
+    7616 NEQ 
+    7617 BRANCHIFNOT 7640
+    7619 ENVACC2 
+    7620 GETFIELD0 
+    7621 PUSHACC1 
+    7622 PUSHENVACC3 
+    7623 APPLY1 
+    7624 EQ 
+    7625 BRANCHIFNOT 7640
+    7627 ACC0 
+    7628 PUSHENVACC 5
+    7630 APPLY1 
+    7631 BRANCHIFNOT 7640
+    7633 ENVACC1 
+    7634 GETFIELD3 
+    7635 PUSHACC1 
+    7636 PUSHENVACC 6
+    7638 APPTERM2 3
+    7640 ACC0 
+    7641 RETURN 1
+    7643 RESTART 
+    7644 GRAB 1
+    7646 CONST0 
+    7647 PUSHENVACC1 
+    7648 OFFSETINT -1
+    7650 PUSH 
+    7651 BRANCH 7690
+    7653 CHECK_SIGNALS 
+    7654 ENVACC2 
+    7655 PUSHACC2 
+    7656 PUSHACC5 
+    7657 C_CALL2 array_get
+    7659 NEQ 
+    7660 BRANCHIFNOT 7679
+    7662 ENVACC2 
+    7663 PUSHACC2 
+    7664 PUSHACC4 
+    7665 C_CALL2 array_get
+    7667 NEQ 
+    7668 BRANCHIFNOT 7679
+    7670 ACC1 
+    7671 PUSHACC3 
+    7672 C_CALL2 array_get
+    7674 PUSHACC2 
+    7675 PUSHACC5 
+    7676 C_CALL2 array_get
+    7678 NEQ 
+    7679 BRANCHIFNOT 7685
+    7681 ENVACC4 
+    7682 MAKEBLOCK1 0
+    7684 RAISE 
+    7685 ACC1 
+    7686 OFFSETINT 1
+    7688 ASSIGN 1
+    7690 ACC0 
+    7691 PUSHACC2 
+    7692 LEINT 
+    7693 BRANCHIF 7653
+    7695 CONST0 
+    7696 POP 2
+    7698 CONST0 
+    7699 PUSHENVACC1 
+    7700 OFFSETINT -1
+    7702 PUSH 
+    7703 BRANCH 7727
+    7705 CHECK_SIGNALS 
+    7706 ENVACC2 
+    7707 PUSHACC2 
+    7708 PUSHACC5 
+    7709 C_CALL2 array_get
+    7711 NEQ 
+    7712 BRANCHIFNOT 7722
+    7714 ACC1 
+    7715 PUSHACC4 
+    7716 C_CALL2 array_get
+    7718 PUSHACC2 
+    7719 PUSHACC4 
+    7720 C_CALL3 array_set
+    7722 ACC1 
+    7723 OFFSETINT 1
+    7725 ASSIGN 1
+    7727 ACC0 
+    7728 PUSHACC2 
+    7729 LEINT 
+    7730 BRANCHIF 7705
+    7732 CONST0 
+    7733 POP 2
+    7735 ENVACC3 
+    7736 GETFIELD0 
+    7737 PUSHACC2 
+    7738 PUSHENVACC 5
+    7740 APPLY2 
+    7741 PUSHENVACC3 
+    7742 SETFIELD0 
+    7743 ACC0 
+    7744 RETURN 2
+    7746 ENVACC1 
+    7747 GETFIELD 4
+    7749 PUSHACC1 
+    7750 PUSHENVACC2 
+    7751 APPLY1 
+    7752 LEINT 
+    7753 RETURN 1
+    7755 CONST0 
+    7756 PUSHCONST0 
+    7757 PUSHENVACC1 
+    7758 OFFSETINT -1
+    7760 PUSH 
+    7761 BRANCH 7782
+    7763 CHECK_SIGNALS 
+    7764 ENVACC2 
+    7765 PUSHACC2 
+    7766 PUSHACC5 
+    7767 C_CALL2 array_get
+    7769 NEQ 
+    7770 BRANCHIFNOT 7777
+    7772 ACC2 
+    7773 OFFSETINT 1
+    7775 ASSIGN 2
+    7777 ACC1 
+    7778 OFFSETINT 1
+    7780 ASSIGN 1
+    7782 ACC0 
+    7783 PUSHACC2 
+    7784 LEINT 
+    7785 BRANCHIF 7763
+    7787 CONST0 
+    7788 POP 2
+    7790 ACC0 
+    7791 RETURN 2
+    7793 ENVACC2 
+    7794 GETFIELD0 
+    7795 OFFSETINT -1
+    7797 PUSHENVACC1 
+    7798 GETFIELD0 
+    7799 C_CALL2 array_get_addr
+    7801 PUSHACC1 
+    7802 PUSHENVACC1 
+    7803 GETFIELD0 
+    7804 C_CALL3 array_set_addr
+    7806 ENVACC2 
+    7807 OFFSETREF -1
+    7809 RETURN 1
+    7811 ENVACC1 
+    7812 GETFIELD0 
+    7813 VECTLENGTH 
+    7814 PUSHACC0 
+    7815 PUSHENVACC2 
+    7816 GETFIELD0 
+    7817 GEINT 
+    7818 BRANCHIFNOT 7845
+    7820 ATOM0 
+    7821 PUSHACC1 
+    7822 PUSHCONST2 
+    7823 MULINT 
+    7824 C_CALL2 make_vect
+    7826 PUSH 
+    7827 PUSH_RETADDR 7840
+    7829 ACC4 
+    7830 PUSHCONST0 
+    7831 PUSHACC5 
+    7832 PUSHCONST0 
+    7833 PUSHENVACC1 
+    7834 GETFIELD0 
+    7835 PUSHGETGLOBALFIELD Array, 8
+    7838 APPLY 5
+    7840 ACC0 
+    7841 PUSHENVACC1 
+    7842 SETFIELD0 
+    7843 POP 1
+    7845 ACC1 
+    7846 PUSHENVACC2 
+    7847 GETFIELD0 
+    7848 PUSHENVACC1 
+    7849 GETFIELD0 
+    7850 C_CALL3 array_set_addr
+    7852 ENVACC2 
+    7853 OFFSETREF 1
+    7855 RETURN 2
+    7857 ACC0 
+    7858 GETFIELD0 
+    7859 PUSHENVACC1 
+    7860 APPLY1 
+    7861 PUSHENVACC2 
+    7862 PUSHACC1 
+    7863 GETFIELD0 
+    7864 EQ 
+    7865 BRANCHIFNOT 7874
+    7867 ACC1 
+    7868 GETFIELD1 
+    7869 PUSHACC1 
+    7870 GETFIELD1 
+    7871 PUSHENVACC3 
+    7872 C_CALL3 array_set
+    7874 RETURN 2
+    7876 RESTART 
+    7877 GRAB 1
+    7879 CONST0 
+    7880 PUSHENVACC2 
+    7881 APPLY1 
+    7882 PUSHACC2 
+    7883 PUSHGETGLOBALFIELD List, 4
+    7886 APPLY1 
+    7887 PUSHACC1 
+    7888 PUSHACC3 
+    7889 PUSHENVACC1 
+    7890 CLOSURE 3, 7857
+    7893 PUSHGETGLOBALFIELD List, 9
+    7896 APPLY2 
+    7897 ACC0 
+    7898 RETURN 3
+    7900 ACC0 
+    7901 PUSHGETGLOBALFIELD Array, 6
+    7904 APPLY1 
+    7905 PUSHACC0 
+    7906 PUSHENVACC3 
+    7907 APPLY1 
+    7908 ENVACC2 
+    7909 GETFIELD0 
+    7910 PUSHENVACC1 
+    7911 PUSHACC2 
+    7912 C_CALL3 array_set
+    7914 ENVACC4 
+    7915 GETFIELD0 
+    7916 PUSHACC1 
+    7917 MAKEBLOCK2 0
+    7919 PUSHENVACC 4
+    7921 SETFIELD0 
+    7922 ACC0 
+    7923 RETURN 2
+    7925 ENVACC2 
+    7926 PUSHENVACC1 
+    7927 OFFSETINT 1
+    7929 C_CALL2 make_vect
+    7931 PUSHACC0 
+    7932 PUSHENVACC3 
+    7933 APPLY1 
+    7934 ENVACC4 
+    7935 GETFIELD0 
+    7936 PUSHACC1 
+    7937 MAKEBLOCK2 0
+    7939 PUSHENVACC 4
+    7941 SETFIELD0 
+    7942 ACC0 
+    7943 RETURN 2
+    7945 ENVACC1 
+    7946 PUSHACC1 
+    7947 C_CALL2 array_get
+    7949 RETURN 1
+    7951 ENVACC2 
+    7952 GETFIELD0 
+    7953 PUSHENVACC1 
+    7954 PUSHACC2 
+    7955 C_CALL3 array_set
+    7957 RETURN 1
+    7959 ENVACC1 
+    7960 PUSHENVACC2 
+    7961 PUSHENVACC1 
+    7962 MULINT 
+    7963 PUSHACC2 
+    7964 MODINT 
+    7965 DIVINT 
+    7966 PUSHENVACC1 
+    7967 PUSHCONSTINT 65536
+    7969 PUSHACC3 
+    7970 DIVINT 
+    7971 DIVINT 
+    7972 MAKEBLOCK2 0
+    7974 RETURN 1
+    7976 ENVACC3 
+    7977 OFFSETREF 1
+    7979 ENVACC1 
+    7980 PUSHACC1 
+    7981 ADDINT 
+    7982 PUSHCONST0 
+    7983 PUSHENVACC2 
+    7984 PUSHENVACC1 
+    7985 MULINT 
+    7986 PUSHACC2 
+    7987 MODINT 
+    7988 EQ 
+    7989 BRANCHIFNOT 8001
+    7991 ENVACC2 
+    7992 PUSHCONSTINT 65536
+    7994 SUBINT 
+    7995 PUSHENVACC1 
+    7996 MULINT 
+    7997 PUSHACC1 
+    7998 ADDINT 
+    7999 RETURN 2
+    8001 ACC0 
+    8002 RETURN 2
+    8004 ACC0 
+    8005 C_CALL1 obj_dup
+    8007 PUSHENVACC1 
+    8008 PUSHACC1 
+    8009 PUSHENVACC2 
+    8010 APPLY2 
+    8011 ACC0 
+    8012 RETURN 2
+    8014 RESTART 
+    8015 GRAB 1
+    8017 ACC1 
+    8018 GETFIELD0 
+    8019 PUSHACC0 
+    8020 PUSHCONST1 
+    8021 PUSHACC3 
+    8022 SETVECTITEM 
+    8023 ACC0 
+    8024 OFFSETINT 1
+    8026 PUSHACC3 
+    8027 SETFIELD0 
+    8028 RETURN 3
+    8030 ENVACC1 
+    8031 GETFIELD0 
+    8032 PUSHENVACC1 
+    8033 OFFSETREF 1
+    8035 ACC0 
+    8036 RETURN 2
+    8038 CONSTINT 248
+    8040 PUSHCONST0 
+    8041 MAKEBLOCK1 0
+    8043 PUSHACC0 
+    8044 CLOSURE 1, 8030
+    8047 PUSH 
+    8048 CLOSURE 0, 8015
+    8051 PUSHACC0 
+    8052 PUSHACC3 
+    8053 CLOSURE 2, 8004
+    8056 PUSHCONSTINT 16
+    8058 PUSHCONST3 
+    8059 PUSHCONST1 
+    8060 PUSHCONST1 
+    8061 PUSHCONST1 
+    8062 MAKEBLOCK 5, 0
+    8065 PUSHCONSTINT 16
+    8067 PUSHGETGLOBALFIELD Sys, 3
+    8070 DIVINT 
+    8071 PUSHCONST0 
+    8072 PUSHCONSTINT 32
+    8074 PUSHCONST2 
+    8075 PUSHCONST0 
+    8076 MAKEBLOCK1 0
+    8078 PUSHACC0 
+    8079 PUSHACC3 
+    8080 PUSHACC6 
+    8081 CLOSURE 3, 7976
+    8084 PUSHACC3 
+    8085 PUSHACC6 
+    8086 CLOSURE 2, 7959
+    8089 PUSHCONST0 
+    8090 PUSHCONST0 
+    8091 MAKEBLOCK1 0
+    8093 PUSHACC0 
+    8094 PUSHACC7 
+    8095 CLOSURE 2, 7951
+    8098 PUSHACC7 
+    8099 CLOSURE 1, 7945
+    8102 PUSHCONST0 
+    8103 MAKEBLOCK1 0
+    8105 PUSH 
+    8106 ATOM0 
+    8107 PUSHACC1 
+    8108 PUSHACC4 
+    8109 PUSHACC7 
+    8110 PUSHACC 13
+    8112 CLOSURE 4, 7925
+    8115 PUSHACC2 
+    8116 PUSHACC5 
+    8117 PUSHACC7 
+    8118 PUSHACC 14
+    8120 CLOSURE 4, 7900
+    8123 PUSHACC1 
+    8124 PUSHACC 9
+    8126 CLOSURE 2, 7877
+    8129 PUSH 
+    8130 ATOM0 
+    8131 PUSHCONSTINT 10
+    8133 C_CALL2 make_vect
+    8135 MAKEBLOCK1 0
+    8137 PUSHCONST0 
+    8138 MAKEBLOCK1 0
+    8140 PUSHACC0 
+    8141 PUSHACC2 
+    8142 CLOSURE 2, 7811
+    8145 PUSHACC1 
+    8146 PUSHACC3 
+    8147 CLOSURE 2, 7793
+    8150 PUSHACC 12
+    8152 PUSHACC 18
+    8154 CLOSURE 2, 7755
+    8157 PUSHACC0 
+    8158 PUSHACC 22
+    8160 CLOSURE 2, 7746
+    8163 PUSHGETGLOBAL "Oo.Failed"
+    8165 MAKEBLOCK1 0
+    8167 PUSH 
+    8168 CLOSUREREC 0, 6415
+    8172 ACC0 
+    8173 PUSHACC2 
+    8174 PUSHACC 14
+    8176 PUSHACC 19
+    8178 PUSHACC 25
+    8180 CLOSURE 5, 7644
+    8183 PUSHACC0 
+    8184 PUSHACC3 
+    8185 PUSHACC5 
+    8186 PUSHACC 8
+    8188 PUSHACC 10
+    8190 PUSHACC 12
+    8192 PUSHACC 14
+    8194 CLOSUREREC 7, 6444
+    8198 ACC0 
+    8199 PUSHACC5 
+    8200 PUSHACC 15
+    8202 PUSHACC 18
+    8204 PUSHACC 21
+    8206 PUSHACC 31
+    8208 CLOSURE 6, 7614
+    8211 PUSHACC0 
+    8212 PUSHACC 26
+    8214 CLOSURE 2, 7582
+    8217 PUSHACC 27
+    8219 PUSHCONSTINT 65536
+    8221 PUSHACC 28
+    8223 MULINT 
+    8224 MULINT 
+    8225 PUSHACC0 
+    8226 MAKEBLOCK1 0
+    8228 PUSHCONSTINT 101
+    8230 PUSHGETGLOBALFIELD Hashtbl, 0
+    8233 APPLY1 
+    8234 PUSHACC1 
+    8235 PUSHACC 26
+    8237 CLOSURE 2, 7571
+    8240 PUSHACC0 
+    8241 PUSHACC2 
+    8242 CLOSURE 2, 7538
+    8245 PUSH 
+    8246 CLOSURE 0, 7530
+    8249 PUSHACC0 
+    8250 MAKEBLOCK1 0
+    8252 POP 1
+    8254 PUSHGETGLOBALFIELD Map, 0
+    8257 APPLY1 
+    8258 PUSH 
+    8259 CLOSURE 0, 7521
+    8262 PUSHACC0 
+    8263 MAKEBLOCK1 0
+    8265 POP 1
+    8267 PUSHGETGLOBALFIELD Map, 0
+    8270 APPLY1 
+    8271 PUSH 
+    8272 CLOSURE 0, 7512
+    8275 PUSHACC0 
+    8276 MAKEBLOCK1 0
+    8278 POP 1
+    8280 PUSHGETGLOBALFIELD Map, 0
+    8283 APPLY1 
+    8284 PUSHCONST0 
+    8285 MAKEBLOCK1 0
+    8287 PUSHACC0 
+    8288 PUSHACC2 
+    8289 PUSHACC4 
+    8290 PUSHACC6 
+    8291 PUSHACC 37
+    8293 CLOSURE 5, 7489
+    8296 PUSHACC 25
+    8298 CLOSURE 1, 7453
+    8301 PUSHACC0 
+    8302 PUSHACC 26
+    8304 PUSHACC 28
+    8306 PUSHACC 35
+    8308 CLOSURE 4, 7409
+    8311 PUSHCONST0 
+    8312 MAKEBLOCK1 0
+    8314 PUSHCONST0 
+    8315 MAKEBLOCK1 0
+    8317 PUSHACC6 
+    8318 PUSHACC 8
+    8320 PUSHACC 12
+    8322 CLOSURE 3, 7362
+    8325 PUSHACC2 
+    8326 PUSHACC4 
+    8327 PUSHACC 9
+    8329 CLOSURE 3, 7328
+    8332 PUSHACC 37
+    8334 CLOSURE 1, 7288
+    8337 PUSHACC2 
+    8338 PUSHACC 10
+    8340 PUSHACC 12
+    8342 PUSHACC 14
+    8344 CLOSURE 4, 7187
+    8347 PUSHACC 12
+    8349 CLOSURE 1, 7027
+    8352 PUSH 
+    8353 CLOSURE 0, 6980
+    8356 PUSH 
+    8357 CLOSURE 0, 6969
+    8360 PUSHACC0 
+    8361 PUSHACC 16
+    8363 CLOSURE 2, 6950
+    8366 PUSHACC 16
+    8368 CLOSURE 1, 6939
+    8371 PUSHACC 47
+    8373 CLOSURE 1, 6927
+    8376 PUSH 
+    8377 CLOSURE 0, 6862
+    8380 PUSHACC 15
+    8382 PUSHACC 18
+    8384 PUSHACC 20
+    8386 PUSHACC 23
+    8388 CLOSURE 4, 6842
+    8391 PUSHACC 12
+    8393 PUSHACC 27
+    8395 PUSHACC 56
+    8397 CLOSURE 3, 6787
+    8400 PUSHACC 57
+    8402 PUSHACC 60
+    8404 PUSHACC 62
+    8406 CLOSURE 3, 6769
+    8409 PUSH 
+    8410 CLOSUREREC 0, 6519
+    8414 ACC0 
+    8415 CLOSURE 1, 6752
+    8418 PUSHACC0 
+    8419 PUSHACC 61
+    8421 PUSHACC 64
+    8423 CLOSURE 3, 6735
+    8426 PUSHACC 52
+    8428 CLOSURE 1, 6715
+    8431 PUSHACC 39
+    8433 PUSHACC 49
+    8435 CLOSURE 2, 6695
+    8438 PUSHACC0 
+    8439 PUSHACC 20
+    8441 PUSHACC 22
+    8443 PUSHACC 27
+    8445 PUSHACC 47
+    8447 PUSHACC 49
+    8449 PUSHACC 55
+    8451 PUSHACC 63
+    8453 CLOSURE 8, 6644
+    8456 PUSHACC 41
+    8458 CLOSURE 1, 6618
+    8461 PUSHACC0 
+    8462 PUSHACC 52
+    8464 PUSHACC 57
+    8466 PUSHACC 63
+    8468 CLOSURE 4, 6581
+    8471 PUSHACC0 
+    8472 PUSHACC3 
+    8473 PUSHACC 66
+    8475 PUSHACC7 
+    8476 PUSHACC 9
+    8478 PUSHACC 11
+    8480 PUSHACC 14
+    8482 PUSHACC 16
+    8484 PUSHACC 18
+    8486 PUSHACC 20
+    8488 PUSHACC 27
+    8490 PUSHACC 29
+    8492 PUSHACC 32
+    8494 PUSHACC 32
+    8496 PUSHACC 35
+    8498 PUSHACC 27
+    8500 PUSHACC 29
+    8502 PUSHACC 31
+    8504 PUSHACC 34
+    8506 PUSHACC 50
+    8508 PUSHACC 85
+    8510 MAKEBLOCK 21, 0
+    8513 POP 70
+    8515 SETGLOBAL Oo
+    8517 BRANCH 8568
+    8519 ACC0 
+    8520 BRANCHIFNOT 8525
+    8522 ACC0 
+    8523 BRANCH 8530
+    8525 ENVACC1 
+    8526 PUSHGETGLOBALFIELD Oo, 14
+    8529 APPLY1 
+    8530 PUSHCONST0 
+    8531 ACC1 
+    8532 BRANCHIFNOT 8537
+    8534 CONST0 
+    8535 BRANCH 8543
+    8537 ENVACC1 
+    8538 PUSHACC1 
+    8539 PUSHGETGLOBALFIELD Oo, 15
+    8542 APPLY2 
+    8543 ACC0 
+    8544 RETURN 2
+    8546 CONSTINT 23
+    8548 RETURN 1
+    8550 CLOSURE 0, 8546
+    8553 PUSHACC0 
+    8554 POP 1
+    8556 PUSHENVACC1 
+    8557 PUSHACC2 
+    8558 PUSHGETGLOBALFIELD Oo, 8
+    8561 APPLY3 
+    8562 ACC0 
+    8563 CLOSURE 1, 8519
+    8566 RETURN 1
+    8568 GETGLOBALFIELD Oo, 1
+    8571 PUSHGETGLOBAL "m"
+    8573 PUSHACC1 
+    8574 APPLY1 
+    8575 PUSHCONST3 
+    8576 C_CALL1 alloc_dummy
+    8578 PUSHGETGLOBAL <0>("m", 0)
+    8580 PUSHGETGLOBALFIELD Oo, 12
+    8583 APPLY1 
+    8584 PUSHACC2 
+    8585 CLOSURE 1, 8550
+    8588 PUSHACC1 
+    8589 PUSHACC1 
+    8590 APPLY1 
+    8591 PUSHACC2 
+    8592 PUSHGETGLOBALFIELD Oo, 13
+    8595 APPLY1 
+    8596 ACC2 
+    8597 PUSHACC2 
+    8598 PUSHACC2 
+    8599 MAKEBLOCK3 0
+    8601 POP 3
+    8603 PUSHACC1 
+    8604 C_CALL2 update_dummy
+    8606 CONST0 
+    8607 PUSHACC1 
+    8608 GETFIELD0 
+    8609 APPLY1 
+    8610 PUSHCONSTINT 23
+    8612 PUSHACC1 
+    8613 PUSHACC4 
+    8614 GETMETHOD 
+    8615 APPLY1 
+    8616 NEQ 
+    8617 BRANCHIFNOT 8624
+    8619 GETGLOBAL Not_found
+    8621 MAKEBLOCK1 0
+    8623 RAISE 
+    8624 POP 1
+    8626 ACC0 
+    8627 MAKEBLOCK1 0
+    8629 POP 3
+    8631 SETGLOBAL T300-getmethod
+    8633 STOP 
+**)
diff --git a/test/testinterp/t301-object.ml b/test/testinterp/t301-object.ml
new file mode 100644
index 00000000..8c142620
--- /dev/null
+++ b/test/testinterp/t301-object.ml
@@ -0,0 +1,29 @@
+(**** file testinterp/t301-object.ml 
+   suggested by Jacques Garrigue to Basile Starynkevitch 
+
+   compilable with
+ocamlc -nostdlib -I ../../stdlib \
+  ../../stdlib/pervasives.cmo ../../stdlib/camlinternalOO.cmo \
+  t301-object.ml -o t301-object.byte
+
+***)
+(* $Id: t301-object.ml,v 1.2 2004/06/02 09:42:01 basile Exp $ *)
+
+
+class c = object (self)
+  method pubmet = 1
+  method privmet = self#pubmet + 1
+  val o = object method a = 3 method m = 4 end
+  method dynmet = o#m
+end;;
+
+let f () =
+  let c = new c in
+  (c#pubmet, c#privmet, c#dynmet);;
+
+let (x,y,z) = f () in
+  if x <> 1 then raise Not_found;
+  if y <> 2 then raise Not_found;
+  if z <> 4 then raise Not_found;;
+
+(**** eof $Id: t301-object.ml,v 1.2 2004/06/02 09:42:01 basile Exp $ *)
diff --git a/test/testinterp/t310-alloc-1.ml b/test/testinterp/t310-alloc-1.ml
new file mode 100644
index 00000000..c438cc97
--- /dev/null
+++ b/test/testinterp/t310-alloc-1.ml
@@ -0,0 +1,1587 @@
+open Lib;;
+let rec f a n =
+  if n <= 0 then a
+  else f (1::a) (n-1)
+in
+let l = f [] 30000 in
+if List.fold_left (+) 0 l <> 30000 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 BRANCH 2177
+    1199 RESTART 
+    1200 GRAB 1
+    1202 ACC1 
+    1203 BRANCHIFNOT 1213
+    1205 ACC1 
+    1206 GETFIELD1 
+    1207 PUSHACC1 
+    1208 OFFSETINT 1
+    1210 PUSHOFFSETCLOSURE0 
+    1211 APPTERM2 4
+    1213 ACC0 
+    1214 RETURN 2
+    1216 RESTART 
+    1217 GRAB 1
+    1219 ACC0 
+    1220 BRANCHIFNOT 1251
+    1222 CONST0 
+    1223 PUSHACC2 
+    1224 EQ 
+    1225 BRANCHIFNOT 1231
+    1227 ACC0 
+    1228 GETFIELD0 
+    1229 RETURN 2
+    1231 CONST0 
+    1232 PUSHACC2 
+    1233 GTINT 
+    1234 BRANCHIFNOT 1244
+    1236 ACC1 
+    1237 OFFSETINT -1
+    1239 PUSHACC1 
+    1240 GETFIELD1 
+    1241 PUSHOFFSETCLOSURE0 
+    1242 APPTERM2 4
+    1244 GETGLOBAL "List.nth"
+    1246 PUSHGETGLOBALFIELD Pervasives, 2
+    1249 APPTERM1 3
+    1251 GETGLOBAL "nth"
+    1253 PUSHGETGLOBALFIELD Pervasives, 3
+    1256 APPTERM1 3
+    1258 RESTART 
+    1259 GRAB 1
+    1261 ACC0 
+    1262 BRANCHIFNOT 1274
+    1264 ACC1 
+    1265 PUSHACC1 
+    1266 GETFIELD0 
+    1267 MAKEBLOCK2 0
+    1269 PUSHACC1 
+    1270 GETFIELD1 
+    1271 PUSHOFFSETCLOSURE0 
+    1272 APPTERM2 4
+    1274 ACC1 
+    1275 RETURN 2
+    1277 ACC0 
+    1278 BRANCHIFNOT 1291
+    1280 ACC0 
+    1281 GETFIELD1 
+    1282 PUSHOFFSETCLOSURE0 
+    1283 APPLY1 
+    1284 PUSHACC1 
+    1285 GETFIELD0 
+    1286 PUSHGETGLOBALFIELD Pervasives, 16
+    1289 APPTERM2 3
+    1291 RETURN 1
+    1293 RESTART 
+    1294 GRAB 1
+    1296 ACC1 
+    1297 BRANCHIFNOT 1313
+    1299 ACC1 
+    1300 GETFIELD0 
+    1301 PUSHACC1 
+    1302 APPLY1 
+    1303 PUSHACC2 
+    1304 GETFIELD1 
+    1305 PUSHACC2 
+    1306 PUSHOFFSETCLOSURE0 
+    1307 APPLY2 
+    1308 PUSHACC1 
+    1309 MAKEBLOCK2 0
+    1311 POP 1
+    1313 RETURN 2
+    1315 RESTART 
+    1316 GRAB 1
+    1318 ACC1 
+    1319 BRANCHIFNOT 1331
+    1321 ACC1 
+    1322 GETFIELD0 
+    1323 PUSHACC1 
+    1324 APPLY1 
+    1325 ACC1 
+    1326 GETFIELD1 
+    1327 PUSHACC1 
+    1328 PUSHOFFSETCLOSURE0 
+    1329 APPTERM2 4
+    1331 RETURN 2
+    1333 RESTART 
+    1334 GRAB 2
+    1336 ACC2 
+    1337 BRANCHIFNOT 1350
+    1339 ACC2 
+    1340 GETFIELD1 
+    1341 PUSHACC3 
+    1342 GETFIELD0 
+    1343 PUSHACC3 
+    1344 PUSHACC3 
+    1345 APPLY2 
+    1346 PUSHACC2 
+    1347 PUSHOFFSETCLOSURE0 
+    1348 APPTERM3 6
+    1350 ACC1 
+    1351 RETURN 3
+    1353 RESTART 
+    1354 GRAB 2
+    1356 ACC1 
+    1357 BRANCHIFNOT 1370
+    1359 ACC2 
+    1360 PUSHACC2 
+    1361 GETFIELD1 
+    1362 PUSHACC2 
+    1363 PUSHOFFSETCLOSURE0 
+    1364 APPLY3 
+    1365 PUSHACC2 
+    1366 GETFIELD0 
+    1367 PUSHACC2 
+    1368 APPTERM2 5
+    1370 ACC2 
+    1371 RETURN 3
+    1373 RESTART 
+    1374 GRAB 2
+    1376 ACC1 
+    1377 BRANCHIFNOT 1400
+    1379 ACC2 
+    1380 BRANCHIFNOT 1407
+    1382 ACC2 
+    1383 GETFIELD0 
+    1384 PUSHACC2 
+    1385 GETFIELD0 
+    1386 PUSHACC2 
+    1387 APPLY2 
+    1388 PUSHACC3 
+    1389 GETFIELD1 
+    1390 PUSHACC3 
+    1391 GETFIELD1 
+    1392 PUSHACC3 
+    1393 PUSHOFFSETCLOSURE0 
+    1394 APPLY3 
+    1395 PUSHACC1 
+    1396 MAKEBLOCK2 0
+    1398 RETURN 4
+    1400 ACC2 
+    1401 BRANCHIFNOT 1405
+    1403 BRANCH 1407
+    1405 RETURN 3
+    1407 GETGLOBAL "List.map2"
+    1409 PUSHGETGLOBALFIELD Pervasives, 2
+    1412 APPTERM1 4
+    1414 RESTART 
+    1415 GRAB 2
+    1417 ACC1 
+    1418 BRANCHIFNOT 1437
+    1420 ACC2 
+    1421 BRANCHIFNOT 1444
+    1423 ACC2 
+    1424 GETFIELD0 
+    1425 PUSHACC2 
+    1426 GETFIELD0 
+    1427 PUSHACC2 
+    1428 APPLY2 
+    1429 ACC2 
+    1430 GETFIELD1 
+    1431 PUSHACC2 
+    1432 GETFIELD1 
+    1433 PUSHACC2 
+    1434 PUSHOFFSETCLOSURE0 
+    1435 APPTERM3 6
+    1437 ACC2 
+    1438 BRANCHIFNOT 1442
+    1440 BRANCH 1444
+    1442 RETURN 3
+    1444 GETGLOBAL "List.iter2"
+    1446 PUSHGETGLOBALFIELD Pervasives, 2
+    1449 APPTERM1 4
+    1451 RESTART 
+    1452 GRAB 3
+    1454 ACC2 
+    1455 BRANCHIFNOT 1476
+    1457 ACC3 
+    1458 BRANCHIFNOT 1482
+    1460 ACC3 
+    1461 GETFIELD1 
+    1462 PUSHACC3 
+    1463 GETFIELD1 
+    1464 PUSHACC5 
+    1465 GETFIELD0 
+    1466 PUSHACC5 
+    1467 GETFIELD0 
+    1468 PUSHACC5 
+    1469 PUSHACC5 
+    1470 APPLY3 
+    1471 PUSHACC3 
+    1472 PUSHOFFSETCLOSURE0 
+    1473 APPTERM 4, 8
+    1476 ACC3 
+    1477 BRANCHIF 1482
+    1479 ACC1 
+    1480 RETURN 4
+    1482 GETGLOBAL "List.fold_left2"
+    1484 PUSHGETGLOBALFIELD Pervasives, 2
+    1487 APPTERM1 5
+    1489 RESTART 
+    1490 GRAB 3
+    1492 ACC1 
+    1493 BRANCHIFNOT 1516
+    1495 ACC2 
+    1496 BRANCHIFNOT 1522
+    1498 PUSH_RETADDR 1509
+    1500 ACC6 
+    1501 PUSHACC6 
+    1502 GETFIELD1 
+    1503 PUSHACC6 
+    1504 GETFIELD1 
+    1505 PUSHACC6 
+    1506 PUSHOFFSETCLOSURE0 
+    1507 APPLY 4
+    1509 PUSHACC3 
+    1510 GETFIELD0 
+    1511 PUSHACC3 
+    1512 GETFIELD0 
+    1513 PUSHACC3 
+    1514 APPTERM3 7
+    1516 ACC2 
+    1517 BRANCHIF 1522
+    1519 ACC3 
+    1520 RETURN 4
+    1522 GETGLOBAL "List.fold_right2"
+    1524 PUSHGETGLOBALFIELD Pervasives, 2
+    1527 APPTERM1 5
+    1529 RESTART 
+    1530 GRAB 1
+    1532 ACC1 
+    1533 BRANCHIFNOT 1549
+    1535 ACC1 
+    1536 GETFIELD0 
+    1537 PUSHACC1 
+    1538 APPLY1 
+    1539 BRANCHIFNOT 1547
+    1541 ACC1 
+    1542 GETFIELD1 
+    1543 PUSHACC1 
+    1544 PUSHOFFSETCLOSURE0 
+    1545 APPTERM2 4
+    1547 RETURN 2
+    1549 CONST1 
+    1550 RETURN 2
+    1552 RESTART 
+    1553 GRAB 1
+    1555 ACC1 
+    1556 BRANCHIFNOT 1570
+    1558 ACC1 
+    1559 GETFIELD0 
+    1560 PUSHACC1 
+    1561 APPLY1 
+    1562 BRANCHIF 1570
+    1564 ACC1 
+    1565 GETFIELD1 
+    1566 PUSHACC1 
+    1567 PUSHOFFSETCLOSURE0 
+    1568 APPTERM2 4
+    1570 RETURN 2
+    1572 RESTART 
+    1573 GRAB 2
+    1575 ACC1 
+    1576 BRANCHIFNOT 1599
+    1578 ACC2 
+    1579 BRANCHIFNOT 1605
+    1581 ACC2 
+    1582 GETFIELD0 
+    1583 PUSHACC2 
+    1584 GETFIELD0 
+    1585 PUSHACC2 
+    1586 APPLY2 
+    1587 BRANCHIFNOT 1597
+    1589 ACC2 
+    1590 GETFIELD1 
+    1591 PUSHACC2 
+    1592 GETFIELD1 
+    1593 PUSHACC2 
+    1594 PUSHOFFSETCLOSURE0 
+    1595 APPTERM3 6
+    1597 RETURN 3
+    1599 ACC2 
+    1600 BRANCHIF 1605
+    1602 CONST1 
+    1603 RETURN 3
+    1605 GETGLOBAL "List.for_all2"
+    1607 PUSHGETGLOBALFIELD Pervasives, 2
+    1610 APPTERM1 4
+    1612 RESTART 
+    1613 GRAB 2
+    1615 ACC1 
+    1616 BRANCHIFNOT 1639
+    1618 ACC2 
+    1619 BRANCHIFNOT 1646
+    1621 ACC2 
+    1622 GETFIELD0 
+    1623 PUSHACC2 
+    1624 GETFIELD0 
+    1625 PUSHACC2 
+    1626 APPLY2 
+    1627 BRANCHIF 1637
+    1629 ACC2 
+    1630 GETFIELD1 
+    1631 PUSHACC2 
+    1632 GETFIELD1 
+    1633 PUSHACC2 
+    1634 PUSHOFFSETCLOSURE0 
+    1635 APPTERM3 6
+    1637 RETURN 3
+    1639 ACC2 
+    1640 BRANCHIFNOT 1644
+    1642 BRANCH 1646
+    1644 RETURN 3
+    1646 GETGLOBAL "List.exists2"
+    1648 PUSHGETGLOBALFIELD Pervasives, 2
+    1651 APPTERM1 4
+    1653 RESTART 
+    1654 GRAB 1
+    1656 ACC1 
+    1657 BRANCHIFNOT 1672
+    1659 ACC0 
+    1660 PUSHACC2 
+    1661 GETFIELD0 
+    1662 C_CALL2 equal
+    1664 BRANCHIF 1672
+    1666 ACC1 
+    1667 GETFIELD1 
+    1668 PUSHACC1 
+    1669 PUSHOFFSETCLOSURE0 
+    1670 APPTERM2 4
+    1672 RETURN 2
+    1674 RESTART 
+    1675 GRAB 1
+    1677 ACC1 
+    1678 BRANCHIFNOT 1692
+    1680 ACC0 
+    1681 PUSHACC2 
+    1682 GETFIELD0 
+    1683 EQ 
+    1684 BRANCHIF 1692
+    1686 ACC1 
+    1687 GETFIELD1 
+    1688 PUSHACC1 
+    1689 PUSHOFFSETCLOSURE0 
+    1690 APPTERM2 4
+    1692 RETURN 2
+    1694 RESTART 
+    1695 GRAB 1
+    1697 ACC1 
+    1698 BRANCHIFNOT 1719
+    1700 ACC1 
+    1701 GETFIELD0 
+    1702 PUSHACC1 
+    1703 PUSHACC1 
+    1704 GETFIELD0 
+    1705 C_CALL2 equal
+    1707 BRANCHIFNOT 1713
+    1709 ACC0 
+    1710 GETFIELD1 
+    1711 RETURN 3
+    1713 ACC2 
+    1714 GETFIELD1 
+    1715 PUSHACC2 
+    1716 PUSHOFFSETCLOSURE0 
+    1717 APPTERM2 5
+    1719 GETGLOBAL Not_found
+    1721 MAKEBLOCK1 0
+    1723 RAISE 
+    1724 RESTART 
+    1725 GRAB 1
+    1727 ACC1 
+    1728 BRANCHIFNOT 1748
+    1730 ACC1 
+    1731 GETFIELD0 
+    1732 PUSHACC1 
+    1733 PUSHACC1 
+    1734 GETFIELD0 
+    1735 EQ 
+    1736 BRANCHIFNOT 1742
+    1738 ACC0 
+    1739 GETFIELD1 
+    1740 RETURN 3
+    1742 ACC2 
+    1743 GETFIELD1 
+    1744 PUSHACC2 
+    1745 PUSHOFFSETCLOSURE0 
+    1746 APPTERM2 5
+    1748 GETGLOBAL Not_found
+    1750 MAKEBLOCK1 0
+    1752 RAISE 
+    1753 RESTART 
+    1754 GRAB 1
+    1756 ACC1 
+    1757 BRANCHIFNOT 1773
+    1759 ACC0 
+    1760 PUSHACC2 
+    1761 GETFIELD0 
+    1762 GETFIELD0 
+    1763 C_CALL2 equal
+    1765 BRANCHIF 1773
+    1767 ACC1 
+    1768 GETFIELD1 
+    1769 PUSHACC1 
+    1770 PUSHOFFSETCLOSURE0 
+    1771 APPTERM2 4
+    1773 RETURN 2
+    1775 RESTART 
+    1776 GRAB 1
+    1778 ACC1 
+    1779 BRANCHIFNOT 1794
+    1781 ACC0 
+    1782 PUSHACC2 
+    1783 GETFIELD0 
+    1784 GETFIELD0 
+    1785 EQ 
+    1786 BRANCHIF 1794
+    1788 ACC1 
+    1789 GETFIELD1 
+    1790 PUSHACC1 
+    1791 PUSHOFFSETCLOSURE0 
+    1792 APPTERM2 4
+    1794 RETURN 2
+    1796 RESTART 
+    1797 GRAB 1
+    1799 ACC1 
+    1800 BRANCHIFNOT 1825
+    1802 ACC1 
+    1803 GETFIELD0 
+    1804 PUSHACC2 
+    1805 GETFIELD1 
+    1806 PUSHACC2 
+    1807 PUSHACC2 
+    1808 GETFIELD0 
+    1809 C_CALL2 equal
+    1811 BRANCHIFNOT 1816
+    1813 ACC0 
+    1814 RETURN 4
+    1816 ACC0 
+    1817 PUSHACC3 
+    1818 PUSHOFFSETCLOSURE0 
+    1819 APPLY2 
+    1820 PUSHACC2 
+    1821 MAKEBLOCK2 0
+    1823 POP 2
+    1825 RETURN 2
+    1827 RESTART 
+    1828 GRAB 1
+    1830 ACC1 
+    1831 BRANCHIFNOT 1855
+    1833 ACC1 
+    1834 GETFIELD0 
+    1835 PUSHACC2 
+    1836 GETFIELD1 
+    1837 PUSHACC2 
+    1838 PUSHACC2 
+    1839 GETFIELD0 
+    1840 EQ 
+    1841 BRANCHIFNOT 1846
+    1843 ACC0 
+    1844 RETURN 4
+    1846 ACC0 
+    1847 PUSHACC3 
+    1848 PUSHOFFSETCLOSURE0 
+    1849 APPLY2 
+    1850 PUSHACC2 
+    1851 MAKEBLOCK2 0
+    1853 POP 2
+    1855 RETURN 2
+    1857 RESTART 
+    1858 GRAB 1
+    1860 ACC1 
+    1861 BRANCHIFNOT 1879
+    1863 ACC1 
+    1864 GETFIELD0 
+    1865 PUSHACC0 
+    1866 PUSHACC2 
+    1867 APPLY1 
+    1868 BRANCHIFNOT 1873
+    1870 ACC0 
+    1871 RETURN 3
+    1873 ACC2 
+    1874 GETFIELD1 
+    1875 PUSHACC2 
+    1876 PUSHOFFSETCLOSURE0 
+    1877 APPTERM2 5
+    1879 GETGLOBAL Not_found
+    1881 MAKEBLOCK1 0
+    1883 RAISE 
+    1884 RESTART 
+    1885 GRAB 2
+    1887 ACC2 
+    1888 BRANCHIFNOT 1917
+    1890 ACC2 
+    1891 GETFIELD0 
+    1892 PUSHACC3 
+    1893 GETFIELD1 
+    1894 PUSHACC1 
+    1895 PUSHENVACC2 
+    1896 APPLY1 
+    1897 BRANCHIFNOT 1908
+    1899 ACC0 
+    1900 PUSHACC4 
+    1901 PUSHACC4 
+    1902 PUSHACC4 
+    1903 MAKEBLOCK2 0
+    1905 PUSHOFFSETCLOSURE0 
+    1906 APPTERM3 8
+    1908 ACC0 
+    1909 PUSHACC4 
+    1910 PUSHACC3 
+    1911 MAKEBLOCK2 0
+    1913 PUSHACC4 
+    1914 PUSHOFFSETCLOSURE0 
+    1915 APPTERM3 8
+    1917 ACC1 
+    1918 PUSHENVACC1 
+    1919 APPLY1 
+    1920 PUSHACC1 
+    1921 PUSHENVACC1 
+    1922 APPLY1 
+    1923 MAKEBLOCK2 0
+    1925 RETURN 3
+    1927 RESTART 
+    1928 GRAB 1
+    1930 ACC0 
+    1931 PUSHENVACC1 
+    1932 CLOSUREREC 2, 1885
+    1936 ACC2 
+    1937 PUSHCONST0 
+    1938 PUSHCONST0 
+    1939 PUSHACC3 
+    1940 APPTERM3 6
+    1942 ACC0 
+    1943 BRANCHIFNOT 1967
+    1945 ACC0 
+    1946 GETFIELD0 
+    1947 PUSHACC1 
+    1948 GETFIELD1 
+    1949 PUSHOFFSETCLOSURE0 
+    1950 APPLY1 
+    1951 PUSHACC0 
+    1952 GETFIELD1 
+    1953 PUSHACC2 
+    1954 GETFIELD1 
+    1955 MAKEBLOCK2 0
+    1957 PUSHACC1 
+    1958 GETFIELD0 
+    1959 PUSHACC3 
+    1960 GETFIELD0 
+    1961 MAKEBLOCK2 0
+    1963 MAKEBLOCK2 0
+    1965 RETURN 3
+    1967 GETGLOBAL <0>(0, 0)
+    1969 RETURN 1
+    1971 RESTART 
+    1972 GRAB 1
+    1974 ACC0 
+    1975 BRANCHIFNOT 1996
+    1977 ACC1 
+    1978 BRANCHIFNOT 2003
+    1980 ACC1 
+    1981 GETFIELD1 
+    1982 PUSHACC1 
+    1983 GETFIELD1 
+    1984 PUSHOFFSETCLOSURE0 
+    1985 APPLY2 
+    1986 PUSHACC2 
+    1987 GETFIELD0 
+    1988 PUSHACC2 
+    1989 GETFIELD0 
+    1990 MAKEBLOCK2 0
+    1992 MAKEBLOCK2 0
+    1994 RETURN 2
+    1996 ACC1 
+    1997 BRANCHIFNOT 2001
+    1999 BRANCH 2003
+    2001 RETURN 2
+    2003 GETGLOBAL "List.combine"
+    2005 PUSHGETGLOBALFIELD Pervasives, 2
+    2008 APPTERM1 3
+    2010 RESTART 
+    2011 GRAB 1
+    2013 ACC1 
+    2014 BRANCHIFNOT 2038
+    2016 ACC1 
+    2017 GETFIELD0 
+    2018 PUSHACC2 
+    2019 GETFIELD1 
+    2020 PUSHACC1 
+    2021 PUSHENVACC2 
+    2022 APPLY1 
+    2023 BRANCHIFNOT 2033
+    2025 ACC0 
+    2026 PUSHACC3 
+    2027 PUSHACC3 
+    2028 MAKEBLOCK2 0
+    2030 PUSHOFFSETCLOSURE0 
+    2031 APPTERM2 6
+    2033 ACC0 
+    2034 PUSHACC3 
+    2035 PUSHOFFSETCLOSURE0 
+    2036 APPTERM2 6
+    2038 ACC0 
+    2039 PUSHENVACC1 
+    2040 APPTERM1 3
+    2042 ACC0 
+    2043 PUSHENVACC1 
+    2044 CLOSUREREC 2, 2011
+    2048 CONST0 
+    2049 PUSHACC1 
+    2050 APPTERM1 3
+    2052 RESTART 
+    2053 GRAB 2
+    2055 ACC1 
+    2056 BRANCHIFNOT 2077
+    2058 ACC2 
+    2059 BRANCHIFNOT 2084
+    2061 ACC2 
+    2062 GETFIELD1 
+    2063 PUSHACC2 
+    2064 GETFIELD1 
+    2065 PUSHACC2 
+    2066 PUSHACC5 
+    2067 GETFIELD0 
+    2068 PUSHACC5 
+    2069 GETFIELD0 
+    2070 PUSHENVACC1 
+    2071 APPLY2 
+    2072 MAKEBLOCK2 0
+    2074 PUSHOFFSETCLOSURE0 
+    2075 APPTERM3 6
+    2077 ACC2 
+    2078 BRANCHIFNOT 2082
+    2080 BRANCH 2084
+    2082 RETURN 3
+    2084 GETGLOBAL "List.rev_map2"
+    2086 PUSHGETGLOBALFIELD Pervasives, 2
+    2089 APPTERM1 4
+    2091 RESTART 
+    2092 GRAB 2
+    2094 ACC0 
+    2095 CLOSUREREC 1, 2053
+    2099 ACC3 
+    2100 PUSHACC3 
+    2101 PUSHCONST0 
+    2102 PUSHACC3 
+    2103 APPTERM3 7
+    2105 RESTART 
+    2106 GRAB 1
+    2108 ACC1 
+    2109 BRANCHIFNOT 2123
+    2111 ACC1 
+    2112 GETFIELD1 
+    2113 PUSHACC1 
+    2114 PUSHACC3 
+    2115 GETFIELD0 
+    2116 PUSHENVACC1 
+    2117 APPLY1 
+    2118 MAKEBLOCK2 0
+    2120 PUSHOFFSETCLOSURE0 
+    2121 APPTERM2 4
+    2123 ACC0 
+    2124 RETURN 2
+    2126 RESTART 
+    2127 GRAB 1
+    2129 ACC0 
+    2130 CLOSUREREC 1, 2106
+    2134 ACC2 
+    2135 PUSHCONST0 
+    2136 PUSHACC2 
+    2137 APPTERM2 5
+    2139 CONST0 
+    2140 PUSHACC1 
+    2141 PUSHENVACC1 
+    2142 APPTERM2 3
+    2144 ACC0 
+    2145 BRANCHIFNOT 2151
+    2147 ACC0 
+    2148 GETFIELD1 
+    2149 RETURN 1
+    2151 GETGLOBAL "tl"
+    2153 PUSHGETGLOBALFIELD Pervasives, 3
+    2156 APPTERM1 2
+    2158 ACC0 
+    2159 BRANCHIFNOT 2165
+    2161 ACC0 
+    2162 GETFIELD0 
+    2163 RETURN 1
+    2165 GETGLOBAL "hd"
+    2167 PUSHGETGLOBALFIELD Pervasives, 3
+    2170 APPTERM1 2
+    2172 ACC0 
+    2173 PUSHCONST0 
+    2174 PUSHENVACC1 
+    2175 APPTERM2 3
+    2177 CLOSUREREC 0, 1200
+    2181 ACC0 
+    2182 CLOSURE 1, 2172
+    2185 PUSH 
+    2186 CLOSURE 0, 2158
+    2189 PUSH 
+    2190 CLOSURE 0, 2144
+    2193 PUSH 
+    2194 CLOSUREREC 0, 1217
+    2198 GETGLOBALFIELD Pervasives, 16
+    2201 PUSH 
+    2202 CLOSUREREC 0, 1259
+    2206 ACC0 
+    2207 CLOSURE 1, 2139
+    2210 PUSH 
+    2211 CLOSUREREC 0, 1277
+    2215 CLOSUREREC 0, 1294
+    2219 CLOSURE 0, 2127
+    2222 PUSH 
+    2223 CLOSUREREC 0, 1316
+    2227 CLOSUREREC 0, 1334
+    2231 CLOSUREREC 0, 1354
+    2235 CLOSUREREC 0, 1374
+    2239 CLOSURE 0, 2092
+    2242 PUSH 
+    2243 CLOSUREREC 0, 1415
+    2247 CLOSUREREC 0, 1452
+    2251 CLOSUREREC 0, 1490
+    2255 CLOSUREREC 0, 1530
+    2259 CLOSUREREC 0, 1553
+    2263 CLOSUREREC 0, 1573
+    2267 CLOSUREREC 0, 1613
+    2271 CLOSUREREC 0, 1654
+    2275 CLOSUREREC 0, 1675
+    2279 CLOSUREREC 0, 1695
+    2283 CLOSUREREC 0, 1725
+    2287 CLOSUREREC 0, 1754
+    2291 CLOSUREREC 0, 1776
+    2295 CLOSUREREC 0, 1797
+    2299 CLOSUREREC 0, 1828
+    2303 CLOSUREREC 0, 1858
+    2307 ACC 24
+    2309 CLOSURE 1, 2042
+    2312 PUSHACC 25
+    2314 CLOSUREREC 1, 1928
+    2318 CLOSUREREC 0, 1942
+    2322 CLOSUREREC 0, 1972
+    2326 ACC0 
+    2327 PUSHACC2 
+    2328 PUSHACC7 
+    2329 PUSHACC 9
+    2331 PUSHACC 11
+    2333 PUSHACC 13
+    2335 PUSHACC 15
+    2337 PUSHACC 17
+    2339 PUSHACC 10
+    2341 PUSHACC 12
+    2343 PUSHACC 13
+    2345 PUSHACC 15
+    2347 PUSHACC 23
+    2349 PUSHACC 25
+    2351 PUSHACC 27
+    2353 PUSHACC 29
+    2355 PUSHACC 31
+    2357 PUSHACC 33
+    2359 PUSHACC 35
+    2361 PUSHACC 37
+    2363 PUSHACC 40
+    2365 PUSHACC 42
+    2367 PUSHACC 41
+    2369 PUSHACC 45
+    2371 PUSHACC 47
+    2373 PUSHACC 50
+    2375 PUSHACC 52
+    2377 PUSHACC 51
+    2379 PUSHACC 55
+    2381 PUSHACC 56
+    2383 PUSHACC 59
+    2385 PUSHACC 61
+    2387 PUSHACC 60
+    2389 PUSHACC 64
+    2391 PUSHACC 66
+    2393 PUSHACC 68
+    2395 PUSHACC 70
+    2397 MAKEBLOCK 37, 0
+    2400 POP 36
+    2402 SETGLOBAL List
+    2404 BRANCH 2435
+    2406 RESTART 
+    2407 GRAB 1
+    2409 CONST0 
+    2410 PUSHACC2 
+    2411 LEINT 
+    2412 BRANCHIFNOT 2417
+    2414 ACC0 
+    2415 RETURN 2
+    2417 ACC1 
+    2418 OFFSETINT -1
+    2420 PUSHACC1 
+    2421 PUSHCONST1 
+    2422 MAKEBLOCK2 0
+    2424 PUSHOFFSETCLOSURE0 
+    2425 APPTERM2 4
+    2427 RESTART 
+    2428 GRAB 1
+    2430 ACC1 
+    2431 PUSHACC1 
+    2432 ADDINT 
+    2433 RETURN 2
+    2435 CLOSUREREC 0, 2407
+    2439 CONSTINT 30000
+    2441 PUSHCONST0 
+    2442 PUSHACC2 
+    2443 APPLY2 
+    2444 PUSHCONSTINT 30000
+    2446 PUSHACC1 
+    2447 PUSHCONST0 
+    2448 PUSH 
+    2449 CLOSURE 0, 2428
+    2452 PUSHGETGLOBALFIELD List, 12
+    2455 APPLY3 
+    2456 NEQ 
+    2457 BRANCHIFNOT 2464
+    2459 GETGLOBAL Not_found
+    2461 MAKEBLOCK1 0
+    2463 RAISE 
+    2464 POP 2
+    2466 ATOM0 
+    2467 SETGLOBAL T310-alloc-1
+    2469 STOP 
+**)
diff --git a/test/testinterp/t310-alloc-2.ml b/test/testinterp/t310-alloc-2.ml
new file mode 100644
index 00000000..81034e78
--- /dev/null
+++ b/test/testinterp/t310-alloc-2.ml
@@ -0,0 +1,2313 @@
+open Lib;;
+let v = Array.make 200000 2 in
+let t = ref 0 in
+Array.iter (fun x -> t := !t + x) v;
+if !t <> 400000 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 BRANCH 2177
+    1199 RESTART 
+    1200 GRAB 1
+    1202 ACC1 
+    1203 BRANCHIFNOT 1213
+    1205 ACC1 
+    1206 GETFIELD1 
+    1207 PUSHACC1 
+    1208 OFFSETINT 1
+    1210 PUSHOFFSETCLOSURE0 
+    1211 APPTERM2 4
+    1213 ACC0 
+    1214 RETURN 2
+    1216 RESTART 
+    1217 GRAB 1
+    1219 ACC0 
+    1220 BRANCHIFNOT 1251
+    1222 CONST0 
+    1223 PUSHACC2 
+    1224 EQ 
+    1225 BRANCHIFNOT 1231
+    1227 ACC0 
+    1228 GETFIELD0 
+    1229 RETURN 2
+    1231 CONST0 
+    1232 PUSHACC2 
+    1233 GTINT 
+    1234 BRANCHIFNOT 1244
+    1236 ACC1 
+    1237 OFFSETINT -1
+    1239 PUSHACC1 
+    1240 GETFIELD1 
+    1241 PUSHOFFSETCLOSURE0 
+    1242 APPTERM2 4
+    1244 GETGLOBAL "List.nth"
+    1246 PUSHGETGLOBALFIELD Pervasives, 2
+    1249 APPTERM1 3
+    1251 GETGLOBAL "nth"
+    1253 PUSHGETGLOBALFIELD Pervasives, 3
+    1256 APPTERM1 3
+    1258 RESTART 
+    1259 GRAB 1
+    1261 ACC0 
+    1262 BRANCHIFNOT 1274
+    1264 ACC1 
+    1265 PUSHACC1 
+    1266 GETFIELD0 
+    1267 MAKEBLOCK2 0
+    1269 PUSHACC1 
+    1270 GETFIELD1 
+    1271 PUSHOFFSETCLOSURE0 
+    1272 APPTERM2 4
+    1274 ACC1 
+    1275 RETURN 2
+    1277 ACC0 
+    1278 BRANCHIFNOT 1291
+    1280 ACC0 
+    1281 GETFIELD1 
+    1282 PUSHOFFSETCLOSURE0 
+    1283 APPLY1 
+    1284 PUSHACC1 
+    1285 GETFIELD0 
+    1286 PUSHGETGLOBALFIELD Pervasives, 16
+    1289 APPTERM2 3
+    1291 RETURN 1
+    1293 RESTART 
+    1294 GRAB 1
+    1296 ACC1 
+    1297 BRANCHIFNOT 1313
+    1299 ACC1 
+    1300 GETFIELD0 
+    1301 PUSHACC1 
+    1302 APPLY1 
+    1303 PUSHACC2 
+    1304 GETFIELD1 
+    1305 PUSHACC2 
+    1306 PUSHOFFSETCLOSURE0 
+    1307 APPLY2 
+    1308 PUSHACC1 
+    1309 MAKEBLOCK2 0
+    1311 POP 1
+    1313 RETURN 2
+    1315 RESTART 
+    1316 GRAB 1
+    1318 ACC1 
+    1319 BRANCHIFNOT 1331
+    1321 ACC1 
+    1322 GETFIELD0 
+    1323 PUSHACC1 
+    1324 APPLY1 
+    1325 ACC1 
+    1326 GETFIELD1 
+    1327 PUSHACC1 
+    1328 PUSHOFFSETCLOSURE0 
+    1329 APPTERM2 4
+    1331 RETURN 2
+    1333 RESTART 
+    1334 GRAB 2
+    1336 ACC2 
+    1337 BRANCHIFNOT 1350
+    1339 ACC2 
+    1340 GETFIELD1 
+    1341 PUSHACC3 
+    1342 GETFIELD0 
+    1343 PUSHACC3 
+    1344 PUSHACC3 
+    1345 APPLY2 
+    1346 PUSHACC2 
+    1347 PUSHOFFSETCLOSURE0 
+    1348 APPTERM3 6
+    1350 ACC1 
+    1351 RETURN 3
+    1353 RESTART 
+    1354 GRAB 2
+    1356 ACC1 
+    1357 BRANCHIFNOT 1370
+    1359 ACC2 
+    1360 PUSHACC2 
+    1361 GETFIELD1 
+    1362 PUSHACC2 
+    1363 PUSHOFFSETCLOSURE0 
+    1364 APPLY3 
+    1365 PUSHACC2 
+    1366 GETFIELD0 
+    1367 PUSHACC2 
+    1368 APPTERM2 5
+    1370 ACC2 
+    1371 RETURN 3
+    1373 RESTART 
+    1374 GRAB 2
+    1376 ACC1 
+    1377 BRANCHIFNOT 1400
+    1379 ACC2 
+    1380 BRANCHIFNOT 1407
+    1382 ACC2 
+    1383 GETFIELD0 
+    1384 PUSHACC2 
+    1385 GETFIELD0 
+    1386 PUSHACC2 
+    1387 APPLY2 
+    1388 PUSHACC3 
+    1389 GETFIELD1 
+    1390 PUSHACC3 
+    1391 GETFIELD1 
+    1392 PUSHACC3 
+    1393 PUSHOFFSETCLOSURE0 
+    1394 APPLY3 
+    1395 PUSHACC1 
+    1396 MAKEBLOCK2 0
+    1398 RETURN 4
+    1400 ACC2 
+    1401 BRANCHIFNOT 1405
+    1403 BRANCH 1407
+    1405 RETURN 3
+    1407 GETGLOBAL "List.map2"
+    1409 PUSHGETGLOBALFIELD Pervasives, 2
+    1412 APPTERM1 4
+    1414 RESTART 
+    1415 GRAB 2
+    1417 ACC1 
+    1418 BRANCHIFNOT 1437
+    1420 ACC2 
+    1421 BRANCHIFNOT 1444
+    1423 ACC2 
+    1424 GETFIELD0 
+    1425 PUSHACC2 
+    1426 GETFIELD0 
+    1427 PUSHACC2 
+    1428 APPLY2 
+    1429 ACC2 
+    1430 GETFIELD1 
+    1431 PUSHACC2 
+    1432 GETFIELD1 
+    1433 PUSHACC2 
+    1434 PUSHOFFSETCLOSURE0 
+    1435 APPTERM3 6
+    1437 ACC2 
+    1438 BRANCHIFNOT 1442
+    1440 BRANCH 1444
+    1442 RETURN 3
+    1444 GETGLOBAL "List.iter2"
+    1446 PUSHGETGLOBALFIELD Pervasives, 2
+    1449 APPTERM1 4
+    1451 RESTART 
+    1452 GRAB 3
+    1454 ACC2 
+    1455 BRANCHIFNOT 1476
+    1457 ACC3 
+    1458 BRANCHIFNOT 1482
+    1460 ACC3 
+    1461 GETFIELD1 
+    1462 PUSHACC3 
+    1463 GETFIELD1 
+    1464 PUSHACC5 
+    1465 GETFIELD0 
+    1466 PUSHACC5 
+    1467 GETFIELD0 
+    1468 PUSHACC5 
+    1469 PUSHACC5 
+    1470 APPLY3 
+    1471 PUSHACC3 
+    1472 PUSHOFFSETCLOSURE0 
+    1473 APPTERM 4, 8
+    1476 ACC3 
+    1477 BRANCHIF 1482
+    1479 ACC1 
+    1480 RETURN 4
+    1482 GETGLOBAL "List.fold_left2"
+    1484 PUSHGETGLOBALFIELD Pervasives, 2
+    1487 APPTERM1 5
+    1489 RESTART 
+    1490 GRAB 3
+    1492 ACC1 
+    1493 BRANCHIFNOT 1516
+    1495 ACC2 
+    1496 BRANCHIFNOT 1522
+    1498 PUSH_RETADDR 1509
+    1500 ACC6 
+    1501 PUSHACC6 
+    1502 GETFIELD1 
+    1503 PUSHACC6 
+    1504 GETFIELD1 
+    1505 PUSHACC6 
+    1506 PUSHOFFSETCLOSURE0 
+    1507 APPLY 4
+    1509 PUSHACC3 
+    1510 GETFIELD0 
+    1511 PUSHACC3 
+    1512 GETFIELD0 
+    1513 PUSHACC3 
+    1514 APPTERM3 7
+    1516 ACC2 
+    1517 BRANCHIF 1522
+    1519 ACC3 
+    1520 RETURN 4
+    1522 GETGLOBAL "List.fold_right2"
+    1524 PUSHGETGLOBALFIELD Pervasives, 2
+    1527 APPTERM1 5
+    1529 RESTART 
+    1530 GRAB 1
+    1532 ACC1 
+    1533 BRANCHIFNOT 1549
+    1535 ACC1 
+    1536 GETFIELD0 
+    1537 PUSHACC1 
+    1538 APPLY1 
+    1539 BRANCHIFNOT 1547
+    1541 ACC1 
+    1542 GETFIELD1 
+    1543 PUSHACC1 
+    1544 PUSHOFFSETCLOSURE0 
+    1545 APPTERM2 4
+    1547 RETURN 2
+    1549 CONST1 
+    1550 RETURN 2
+    1552 RESTART 
+    1553 GRAB 1
+    1555 ACC1 
+    1556 BRANCHIFNOT 1570
+    1558 ACC1 
+    1559 GETFIELD0 
+    1560 PUSHACC1 
+    1561 APPLY1 
+    1562 BRANCHIF 1570
+    1564 ACC1 
+    1565 GETFIELD1 
+    1566 PUSHACC1 
+    1567 PUSHOFFSETCLOSURE0 
+    1568 APPTERM2 4
+    1570 RETURN 2
+    1572 RESTART 
+    1573 GRAB 2
+    1575 ACC1 
+    1576 BRANCHIFNOT 1599
+    1578 ACC2 
+    1579 BRANCHIFNOT 1605
+    1581 ACC2 
+    1582 GETFIELD0 
+    1583 PUSHACC2 
+    1584 GETFIELD0 
+    1585 PUSHACC2 
+    1586 APPLY2 
+    1587 BRANCHIFNOT 1597
+    1589 ACC2 
+    1590 GETFIELD1 
+    1591 PUSHACC2 
+    1592 GETFIELD1 
+    1593 PUSHACC2 
+    1594 PUSHOFFSETCLOSURE0 
+    1595 APPTERM3 6
+    1597 RETURN 3
+    1599 ACC2 
+    1600 BRANCHIF 1605
+    1602 CONST1 
+    1603 RETURN 3
+    1605 GETGLOBAL "List.for_all2"
+    1607 PUSHGETGLOBALFIELD Pervasives, 2
+    1610 APPTERM1 4
+    1612 RESTART 
+    1613 GRAB 2
+    1615 ACC1 
+    1616 BRANCHIFNOT 1639
+    1618 ACC2 
+    1619 BRANCHIFNOT 1646
+    1621 ACC2 
+    1622 GETFIELD0 
+    1623 PUSHACC2 
+    1624 GETFIELD0 
+    1625 PUSHACC2 
+    1626 APPLY2 
+    1627 BRANCHIF 1637
+    1629 ACC2 
+    1630 GETFIELD1 
+    1631 PUSHACC2 
+    1632 GETFIELD1 
+    1633 PUSHACC2 
+    1634 PUSHOFFSETCLOSURE0 
+    1635 APPTERM3 6
+    1637 RETURN 3
+    1639 ACC2 
+    1640 BRANCHIFNOT 1644
+    1642 BRANCH 1646
+    1644 RETURN 3
+    1646 GETGLOBAL "List.exists2"
+    1648 PUSHGETGLOBALFIELD Pervasives, 2
+    1651 APPTERM1 4
+    1653 RESTART 
+    1654 GRAB 1
+    1656 ACC1 
+    1657 BRANCHIFNOT 1672
+    1659 ACC0 
+    1660 PUSHACC2 
+    1661 GETFIELD0 
+    1662 C_CALL2 equal
+    1664 BRANCHIF 1672
+    1666 ACC1 
+    1667 GETFIELD1 
+    1668 PUSHACC1 
+    1669 PUSHOFFSETCLOSURE0 
+    1670 APPTERM2 4
+    1672 RETURN 2
+    1674 RESTART 
+    1675 GRAB 1
+    1677 ACC1 
+    1678 BRANCHIFNOT 1692
+    1680 ACC0 
+    1681 PUSHACC2 
+    1682 GETFIELD0 
+    1683 EQ 
+    1684 BRANCHIF 1692
+    1686 ACC1 
+    1687 GETFIELD1 
+    1688 PUSHACC1 
+    1689 PUSHOFFSETCLOSURE0 
+    1690 APPTERM2 4
+    1692 RETURN 2
+    1694 RESTART 
+    1695 GRAB 1
+    1697 ACC1 
+    1698 BRANCHIFNOT 1719
+    1700 ACC1 
+    1701 GETFIELD0 
+    1702 PUSHACC1 
+    1703 PUSHACC1 
+    1704 GETFIELD0 
+    1705 C_CALL2 equal
+    1707 BRANCHIFNOT 1713
+    1709 ACC0 
+    1710 GETFIELD1 
+    1711 RETURN 3
+    1713 ACC2 
+    1714 GETFIELD1 
+    1715 PUSHACC2 
+    1716 PUSHOFFSETCLOSURE0 
+    1717 APPTERM2 5
+    1719 GETGLOBAL Not_found
+    1721 MAKEBLOCK1 0
+    1723 RAISE 
+    1724 RESTART 
+    1725 GRAB 1
+    1727 ACC1 
+    1728 BRANCHIFNOT 1748
+    1730 ACC1 
+    1731 GETFIELD0 
+    1732 PUSHACC1 
+    1733 PUSHACC1 
+    1734 GETFIELD0 
+    1735 EQ 
+    1736 BRANCHIFNOT 1742
+    1738 ACC0 
+    1739 GETFIELD1 
+    1740 RETURN 3
+    1742 ACC2 
+    1743 GETFIELD1 
+    1744 PUSHACC2 
+    1745 PUSHOFFSETCLOSURE0 
+    1746 APPTERM2 5
+    1748 GETGLOBAL Not_found
+    1750 MAKEBLOCK1 0
+    1752 RAISE 
+    1753 RESTART 
+    1754 GRAB 1
+    1756 ACC1 
+    1757 BRANCHIFNOT 1773
+    1759 ACC0 
+    1760 PUSHACC2 
+    1761 GETFIELD0 
+    1762 GETFIELD0 
+    1763 C_CALL2 equal
+    1765 BRANCHIF 1773
+    1767 ACC1 
+    1768 GETFIELD1 
+    1769 PUSHACC1 
+    1770 PUSHOFFSETCLOSURE0 
+    1771 APPTERM2 4
+    1773 RETURN 2
+    1775 RESTART 
+    1776 GRAB 1
+    1778 ACC1 
+    1779 BRANCHIFNOT 1794
+    1781 ACC0 
+    1782 PUSHACC2 
+    1783 GETFIELD0 
+    1784 GETFIELD0 
+    1785 EQ 
+    1786 BRANCHIF 1794
+    1788 ACC1 
+    1789 GETFIELD1 
+    1790 PUSHACC1 
+    1791 PUSHOFFSETCLOSURE0 
+    1792 APPTERM2 4
+    1794 RETURN 2
+    1796 RESTART 
+    1797 GRAB 1
+    1799 ACC1 
+    1800 BRANCHIFNOT 1825
+    1802 ACC1 
+    1803 GETFIELD0 
+    1804 PUSHACC2 
+    1805 GETFIELD1 
+    1806 PUSHACC2 
+    1807 PUSHACC2 
+    1808 GETFIELD0 
+    1809 C_CALL2 equal
+    1811 BRANCHIFNOT 1816
+    1813 ACC0 
+    1814 RETURN 4
+    1816 ACC0 
+    1817 PUSHACC3 
+    1818 PUSHOFFSETCLOSURE0 
+    1819 APPLY2 
+    1820 PUSHACC2 
+    1821 MAKEBLOCK2 0
+    1823 POP 2
+    1825 RETURN 2
+    1827 RESTART 
+    1828 GRAB 1
+    1830 ACC1 
+    1831 BRANCHIFNOT 1855
+    1833 ACC1 
+    1834 GETFIELD0 
+    1835 PUSHACC2 
+    1836 GETFIELD1 
+    1837 PUSHACC2 
+    1838 PUSHACC2 
+    1839 GETFIELD0 
+    1840 EQ 
+    1841 BRANCHIFNOT 1846
+    1843 ACC0 
+    1844 RETURN 4
+    1846 ACC0 
+    1847 PUSHACC3 
+    1848 PUSHOFFSETCLOSURE0 
+    1849 APPLY2 
+    1850 PUSHACC2 
+    1851 MAKEBLOCK2 0
+    1853 POP 2
+    1855 RETURN 2
+    1857 RESTART 
+    1858 GRAB 1
+    1860 ACC1 
+    1861 BRANCHIFNOT 1879
+    1863 ACC1 
+    1864 GETFIELD0 
+    1865 PUSHACC0 
+    1866 PUSHACC2 
+    1867 APPLY1 
+    1868 BRANCHIFNOT 1873
+    1870 ACC0 
+    1871 RETURN 3
+    1873 ACC2 
+    1874 GETFIELD1 
+    1875 PUSHACC2 
+    1876 PUSHOFFSETCLOSURE0 
+    1877 APPTERM2 5
+    1879 GETGLOBAL Not_found
+    1881 MAKEBLOCK1 0
+    1883 RAISE 
+    1884 RESTART 
+    1885 GRAB 2
+    1887 ACC2 
+    1888 BRANCHIFNOT 1917
+    1890 ACC2 
+    1891 GETFIELD0 
+    1892 PUSHACC3 
+    1893 GETFIELD1 
+    1894 PUSHACC1 
+    1895 PUSHENVACC2 
+    1896 APPLY1 
+    1897 BRANCHIFNOT 1908
+    1899 ACC0 
+    1900 PUSHACC4 
+    1901 PUSHACC4 
+    1902 PUSHACC4 
+    1903 MAKEBLOCK2 0
+    1905 PUSHOFFSETCLOSURE0 
+    1906 APPTERM3 8
+    1908 ACC0 
+    1909 PUSHACC4 
+    1910 PUSHACC3 
+    1911 MAKEBLOCK2 0
+    1913 PUSHACC4 
+    1914 PUSHOFFSETCLOSURE0 
+    1915 APPTERM3 8
+    1917 ACC1 
+    1918 PUSHENVACC1 
+    1919 APPLY1 
+    1920 PUSHACC1 
+    1921 PUSHENVACC1 
+    1922 APPLY1 
+    1923 MAKEBLOCK2 0
+    1925 RETURN 3
+    1927 RESTART 
+    1928 GRAB 1
+    1930 ACC0 
+    1931 PUSHENVACC1 
+    1932 CLOSUREREC 2, 1885
+    1936 ACC2 
+    1937 PUSHCONST0 
+    1938 PUSHCONST0 
+    1939 PUSHACC3 
+    1940 APPTERM3 6
+    1942 ACC0 
+    1943 BRANCHIFNOT 1967
+    1945 ACC0 
+    1946 GETFIELD0 
+    1947 PUSHACC1 
+    1948 GETFIELD1 
+    1949 PUSHOFFSETCLOSURE0 
+    1950 APPLY1 
+    1951 PUSHACC0 
+    1952 GETFIELD1 
+    1953 PUSHACC2 
+    1954 GETFIELD1 
+    1955 MAKEBLOCK2 0
+    1957 PUSHACC1 
+    1958 GETFIELD0 
+    1959 PUSHACC3 
+    1960 GETFIELD0 
+    1961 MAKEBLOCK2 0
+    1963 MAKEBLOCK2 0
+    1965 RETURN 3
+    1967 GETGLOBAL <0>(0, 0)
+    1969 RETURN 1
+    1971 RESTART 
+    1972 GRAB 1
+    1974 ACC0 
+    1975 BRANCHIFNOT 1996
+    1977 ACC1 
+    1978 BRANCHIFNOT 2003
+    1980 ACC1 
+    1981 GETFIELD1 
+    1982 PUSHACC1 
+    1983 GETFIELD1 
+    1984 PUSHOFFSETCLOSURE0 
+    1985 APPLY2 
+    1986 PUSHACC2 
+    1987 GETFIELD0 
+    1988 PUSHACC2 
+    1989 GETFIELD0 
+    1990 MAKEBLOCK2 0
+    1992 MAKEBLOCK2 0
+    1994 RETURN 2
+    1996 ACC1 
+    1997 BRANCHIFNOT 2001
+    1999 BRANCH 2003
+    2001 RETURN 2
+    2003 GETGLOBAL "List.combine"
+    2005 PUSHGETGLOBALFIELD Pervasives, 2
+    2008 APPTERM1 3
+    2010 RESTART 
+    2011 GRAB 1
+    2013 ACC1 
+    2014 BRANCHIFNOT 2038
+    2016 ACC1 
+    2017 GETFIELD0 
+    2018 PUSHACC2 
+    2019 GETFIELD1 
+    2020 PUSHACC1 
+    2021 PUSHENVACC2 
+    2022 APPLY1 
+    2023 BRANCHIFNOT 2033
+    2025 ACC0 
+    2026 PUSHACC3 
+    2027 PUSHACC3 
+    2028 MAKEBLOCK2 0
+    2030 PUSHOFFSETCLOSURE0 
+    2031 APPTERM2 6
+    2033 ACC0 
+    2034 PUSHACC3 
+    2035 PUSHOFFSETCLOSURE0 
+    2036 APPTERM2 6
+    2038 ACC0 
+    2039 PUSHENVACC1 
+    2040 APPTERM1 3
+    2042 ACC0 
+    2043 PUSHENVACC1 
+    2044 CLOSUREREC 2, 2011
+    2048 CONST0 
+    2049 PUSHACC1 
+    2050 APPTERM1 3
+    2052 RESTART 
+    2053 GRAB 2
+    2055 ACC1 
+    2056 BRANCHIFNOT 2077
+    2058 ACC2 
+    2059 BRANCHIFNOT 2084
+    2061 ACC2 
+    2062 GETFIELD1 
+    2063 PUSHACC2 
+    2064 GETFIELD1 
+    2065 PUSHACC2 
+    2066 PUSHACC5 
+    2067 GETFIELD0 
+    2068 PUSHACC5 
+    2069 GETFIELD0 
+    2070 PUSHENVACC1 
+    2071 APPLY2 
+    2072 MAKEBLOCK2 0
+    2074 PUSHOFFSETCLOSURE0 
+    2075 APPTERM3 6
+    2077 ACC2 
+    2078 BRANCHIFNOT 2082
+    2080 BRANCH 2084
+    2082 RETURN 3
+    2084 GETGLOBAL "List.rev_map2"
+    2086 PUSHGETGLOBALFIELD Pervasives, 2
+    2089 APPTERM1 4
+    2091 RESTART 
+    2092 GRAB 2
+    2094 ACC0 
+    2095 CLOSUREREC 1, 2053
+    2099 ACC3 
+    2100 PUSHACC3 
+    2101 PUSHCONST0 
+    2102 PUSHACC3 
+    2103 APPTERM3 7
+    2105 RESTART 
+    2106 GRAB 1
+    2108 ACC1 
+    2109 BRANCHIFNOT 2123
+    2111 ACC1 
+    2112 GETFIELD1 
+    2113 PUSHACC1 
+    2114 PUSHACC3 
+    2115 GETFIELD0 
+    2116 PUSHENVACC1 
+    2117 APPLY1 
+    2118 MAKEBLOCK2 0
+    2120 PUSHOFFSETCLOSURE0 
+    2121 APPTERM2 4
+    2123 ACC0 
+    2124 RETURN 2
+    2126 RESTART 
+    2127 GRAB 1
+    2129 ACC0 
+    2130 CLOSUREREC 1, 2106
+    2134 ACC2 
+    2135 PUSHCONST0 
+    2136 PUSHACC2 
+    2137 APPTERM2 5
+    2139 CONST0 
+    2140 PUSHACC1 
+    2141 PUSHENVACC1 
+    2142 APPTERM2 3
+    2144 ACC0 
+    2145 BRANCHIFNOT 2151
+    2147 ACC0 
+    2148 GETFIELD1 
+    2149 RETURN 1
+    2151 GETGLOBAL "tl"
+    2153 PUSHGETGLOBALFIELD Pervasives, 3
+    2156 APPTERM1 2
+    2158 ACC0 
+    2159 BRANCHIFNOT 2165
+    2161 ACC0 
+    2162 GETFIELD0 
+    2163 RETURN 1
+    2165 GETGLOBAL "hd"
+    2167 PUSHGETGLOBALFIELD Pervasives, 3
+    2170 APPTERM1 2
+    2172 ACC0 
+    2173 PUSHCONST0 
+    2174 PUSHENVACC1 
+    2175 APPTERM2 3
+    2177 CLOSUREREC 0, 1200
+    2181 ACC0 
+    2182 CLOSURE 1, 2172
+    2185 PUSH 
+    2186 CLOSURE 0, 2158
+    2189 PUSH 
+    2190 CLOSURE 0, 2144
+    2193 PUSH 
+    2194 CLOSUREREC 0, 1217
+    2198 GETGLOBALFIELD Pervasives, 16
+    2201 PUSH 
+    2202 CLOSUREREC 0, 1259
+    2206 ACC0 
+    2207 CLOSURE 1, 2139
+    2210 PUSH 
+    2211 CLOSUREREC 0, 1277
+    2215 CLOSUREREC 0, 1294
+    2219 CLOSURE 0, 2127
+    2222 PUSH 
+    2223 CLOSUREREC 0, 1316
+    2227 CLOSUREREC 0, 1334
+    2231 CLOSUREREC 0, 1354
+    2235 CLOSUREREC 0, 1374
+    2239 CLOSURE 0, 2092
+    2242 PUSH 
+    2243 CLOSUREREC 0, 1415
+    2247 CLOSUREREC 0, 1452
+    2251 CLOSUREREC 0, 1490
+    2255 CLOSUREREC 0, 1530
+    2259 CLOSUREREC 0, 1553
+    2263 CLOSUREREC 0, 1573
+    2267 CLOSUREREC 0, 1613
+    2271 CLOSUREREC 0, 1654
+    2275 CLOSUREREC 0, 1675
+    2279 CLOSUREREC 0, 1695
+    2283 CLOSUREREC 0, 1725
+    2287 CLOSUREREC 0, 1754
+    2291 CLOSUREREC 0, 1776
+    2295 CLOSUREREC 0, 1797
+    2299 CLOSUREREC 0, 1828
+    2303 CLOSUREREC 0, 1858
+    2307 ACC 24
+    2309 CLOSURE 1, 2042
+    2312 PUSHACC 25
+    2314 CLOSUREREC 1, 1928
+    2318 CLOSUREREC 0, 1942
+    2322 CLOSUREREC 0, 1972
+    2326 ACC0 
+    2327 PUSHACC2 
+    2328 PUSHACC7 
+    2329 PUSHACC 9
+    2331 PUSHACC 11
+    2333 PUSHACC 13
+    2335 PUSHACC 15
+    2337 PUSHACC 17
+    2339 PUSHACC 10
+    2341 PUSHACC 12
+    2343 PUSHACC 13
+    2345 PUSHACC 15
+    2347 PUSHACC 23
+    2349 PUSHACC 25
+    2351 PUSHACC 27
+    2353 PUSHACC 29
+    2355 PUSHACC 31
+    2357 PUSHACC 33
+    2359 PUSHACC 35
+    2361 PUSHACC 37
+    2363 PUSHACC 40
+    2365 PUSHACC 42
+    2367 PUSHACC 41
+    2369 PUSHACC 45
+    2371 PUSHACC 47
+    2373 PUSHACC 50
+    2375 PUSHACC 52
+    2377 PUSHACC 51
+    2379 PUSHACC 55
+    2381 PUSHACC 56
+    2383 PUSHACC 59
+    2385 PUSHACC 61
+    2387 PUSHACC 60
+    2389 PUSHACC 64
+    2391 PUSHACC 66
+    2393 PUSHACC 68
+    2395 PUSHACC 70
+    2397 MAKEBLOCK 37, 0
+    2400 POP 36
+    2402 SETGLOBAL List
+    2404 BRANCH 3341
+    2406 RESTART 
+    2407 GRAB 2
+    2409 ACC2 
+    2410 PUSHACC2 
+    2411 VECTLENGTH 
+    2412 OFFSETINT -1
+    2414 PUSHCONST0 
+    2415 PUSH 
+    2416 BRANCH 2433
+    2418 CHECK_SIGNALS 
+    2419 ACC2 
+    2420 PUSHACC2 
+    2421 PUSHACC6 
+    2422 C_CALL2 array_unsafe_get
+    2424 PUSHACC5 
+    2425 APPLY2 
+    2426 ASSIGN 2
+    2428 ACC1 
+    2429 OFFSETINT -1
+    2431 ASSIGN 1
+    2433 ACC0 
+    2434 PUSHACC2 
+    2435 GEINT 
+    2436 BRANCHIF 2418
+    2438 CONST0 
+    2439 POP 2
+    2441 ACC0 
+    2442 RETURN 4
+    2444 RESTART 
+    2445 GRAB 2
+    2447 ACC1 
+    2448 PUSHCONST0 
+    2449 PUSHACC4 
+    2450 VECTLENGTH 
+    2451 OFFSETINT -1
+    2453 PUSH 
+    2454 BRANCH 2471
+    2456 CHECK_SIGNALS 
+    2457 ACC1 
+    2458 PUSHACC6 
+    2459 C_CALL2 array_unsafe_get
+    2461 PUSHACC3 
+    2462 PUSHACC5 
+    2463 APPLY2 
+    2464 ASSIGN 2
+    2466 ACC1 
+    2467 OFFSETINT 1
+    2469 ASSIGN 1
+    2471 ACC0 
+    2472 PUSHACC2 
+    2473 LEINT 
+    2474 BRANCHIF 2456
+    2476 CONST0 
+    2477 POP 2
+    2479 ACC0 
+    2480 RETURN 4
+    2482 RESTART 
+    2483 GRAB 1
+    2485 ACC1 
+    2486 BRANCHIFNOT 2502
+    2488 ACC1 
+    2489 GETFIELD0 
+    2490 PUSHACC1 
+    2491 PUSHENVACC1 
+    2492 C_CALL3 array_unsafe_set
+    2494 ACC1 
+    2495 GETFIELD1 
+    2496 PUSHACC1 
+    2497 OFFSETINT 1
+    2499 PUSHOFFSETCLOSURE0 
+    2500 APPTERM2 4
+    2502 ENVACC1 
+    2503 RETURN 2
+    2505 ACC0 
+    2506 BRANCHIFNOT 2531
+    2508 ACC0 
+    2509 GETFIELD1 
+    2510 PUSHACC1 
+    2511 GETFIELD0 
+    2512 PUSHACC1 
+    2513 PUSHGETGLOBALFIELD List, 0
+    2516 APPLY1 
+    2517 OFFSETINT 1
+    2519 C_CALL2 make_vect
+    2521 PUSHACC0 
+    2522 CLOSUREREC 1, 2483
+    2526 ACC2 
+    2527 PUSHCONST1 
+    2528 PUSHACC2 
+    2529 APPTERM2 6
+    2531 ATOM0 
+    2532 RETURN 1
+    2534 RESTART 
+    2535 GRAB 1
+    2537 CONST0 
+    2538 PUSHACC1 
+    2539 LTINT 
+    2540 BRANCHIFNOT 2545
+    2542 ACC1 
+    2543 RETURN 2
+    2545 ACC1 
+    2546 PUSHACC1 
+    2547 PUSHENVACC1 
+    2548 C_CALL2 array_unsafe_get
+    2550 MAKEBLOCK2 0
+    2552 PUSHACC1 
+    2553 OFFSETINT -1
+    2555 PUSHOFFSETCLOSURE0 
+    2556 APPTERM2 4
+    2558 ACC0 
+    2559 CLOSUREREC 1, 2535
+    2563 CONST0 
+    2564 PUSHACC2 
+    2565 VECTLENGTH 
+    2566 OFFSETINT -1
+    2568 PUSHACC2 
+    2569 APPTERM2 4
+    2571 RESTART 
+    2572 GRAB 1
+    2574 ACC1 
+    2575 VECTLENGTH 
+    2576 PUSHCONST0 
+    2577 PUSHACC1 
+    2578 EQ 
+    2579 BRANCHIFNOT 2584
+    2581 ATOM0 
+    2582 RETURN 3
+    2584 CONST0 
+    2585 PUSHACC3 
+    2586 C_CALL2 array_unsafe_get
+    2588 PUSHCONST0 
+    2589 PUSHACC3 
+    2590 APPLY2 
+    2591 PUSHACC1 
+    2592 C_CALL2 make_vect
+    2594 PUSHCONST1 
+    2595 PUSHACC2 
+    2596 OFFSETINT -1
+    2598 PUSH 
+    2599 BRANCH 2618
+    2601 CHECK_SIGNALS 
+    2602 ACC1 
+    2603 PUSHACC6 
+    2604 C_CALL2 array_unsafe_get
+    2606 PUSHACC2 
+    2607 PUSHACC6 
+    2608 APPLY2 
+    2609 PUSHACC2 
+    2610 PUSHACC4 
+    2611 C_CALL3 array_unsafe_set
+    2613 ACC1 
+    2614 OFFSETINT 1
+    2616 ASSIGN 1
+    2618 ACC0 
+    2619 PUSHACC2 
+    2620 LEINT 
+    2621 BRANCHIF 2601
+    2623 CONST0 
+    2624 POP 2
+    2626 ACC0 
+    2627 RETURN 4
+    2629 RESTART 
+    2630 GRAB 1
+    2632 CONST0 
+    2633 PUSHACC2 
+    2634 VECTLENGTH 
+    2635 OFFSETINT -1
+    2637 PUSH 
+    2638 BRANCH 2653
+    2640 CHECK_SIGNALS 
+    2641 ACC1 
+    2642 PUSHACC4 
+    2643 C_CALL2 array_unsafe_get
+    2645 PUSHACC2 
+    2646 PUSHACC4 
+    2647 APPLY2 
+    2648 ACC1 
+    2649 OFFSETINT 1
+    2651 ASSIGN 1
+    2653 ACC0 
+    2654 PUSHACC2 
+    2655 LEINT 
+    2656 BRANCHIF 2640
+    2658 CONST0 
+    2659 RETURN 4
+    2661 RESTART 
+    2662 GRAB 1
+    2664 ACC1 
+    2665 VECTLENGTH 
+    2666 PUSHCONST0 
+    2667 PUSHACC1 
+    2668 EQ 
+    2669 BRANCHIFNOT 2674
+    2671 ATOM0 
+    2672 RETURN 3
+    2674 CONST0 
+    2675 PUSHACC3 
+    2676 C_CALL2 array_unsafe_get
+    2678 PUSHACC2 
+    2679 APPLY1 
+    2680 PUSHACC1 
+    2681 C_CALL2 make_vect
+    2683 PUSHCONST1 
+    2684 PUSHACC2 
+    2685 OFFSETINT -1
+    2687 PUSH 
+    2688 BRANCH 2706
+    2690 CHECK_SIGNALS 
+    2691 ACC1 
+    2692 PUSHACC6 
+    2693 C_CALL2 array_unsafe_get
+    2695 PUSHACC5 
+    2696 APPLY1 
+    2697 PUSHACC2 
+    2698 PUSHACC4 
+    2699 C_CALL3 array_unsafe_set
+    2701 ACC1 
+    2702 OFFSETINT 1
+    2704 ASSIGN 1
+    2706 ACC0 
+    2707 PUSHACC2 
+    2708 LEINT 
+    2709 BRANCHIF 2690
+    2711 CONST0 
+    2712 POP 2
+    2714 ACC0 
+    2715 RETURN 4
+    2717 RESTART 
+    2718 GRAB 1
+    2720 CONST0 
+    2721 PUSHACC2 
+    2722 VECTLENGTH 
+    2723 OFFSETINT -1
+    2725 PUSH 
+    2726 BRANCH 2740
+    2728 CHECK_SIGNALS 
+    2729 ACC1 
+    2730 PUSHACC4 
+    2731 C_CALL2 array_unsafe_get
+    2733 PUSHACC3 
+    2734 APPLY1 
+    2735 ACC1 
+    2736 OFFSETINT 1
+    2738 ASSIGN 1
+    2740 ACC0 
+    2741 PUSHACC2 
+    2742 LEINT 
+    2743 BRANCHIF 2728
+    2745 CONST0 
+    2746 RETURN 4
+    2748 RESTART 
+    2749 GRAB 4
+    2751 CONST0 
+    2752 PUSHACC5 
+    2753 LTINT 
+    2754 BRANCHIF 2782
+    2756 CONST0 
+    2757 PUSHACC2 
+    2758 LTINT 
+    2759 BRANCHIF 2782
+    2761 ACC0 
+    2762 VECTLENGTH 
+    2763 PUSHACC5 
+    2764 PUSHACC3 
+    2765 ADDINT 
+    2766 GTINT 
+    2767 BRANCHIF 2782
+    2769 CONST0 
+    2770 PUSHACC4 
+    2771 LTINT 
+    2772 BRANCHIF 2782
+    2774 ACC2 
+    2775 VECTLENGTH 
+    2776 PUSHACC5 
+    2777 PUSHACC5 
+    2778 ADDINT 
+    2779 GTINT 
+    2780 BRANCHIFNOT 2789
+    2782 GETGLOBAL "Array.blit"
+    2784 PUSHGETGLOBALFIELD Pervasives, 2
+    2787 APPTERM1 6
+    2789 ACC3 
+    2790 PUSHACC2 
+    2791 LTINT 
+    2792 BRANCHIFNOT 2827
+    2794 ACC4 
+    2795 OFFSETINT -1
+    2797 PUSHCONST0 
+    2798 PUSH 
+    2799 BRANCH 2819
+    2801 CHECK_SIGNALS 
+    2802 ACC1 
+    2803 PUSHACC4 
+    2804 ADDINT 
+    2805 PUSHACC3 
+    2806 C_CALL2 array_unsafe_get
+    2808 PUSHACC2 
+    2809 PUSHACC7 
+    2810 ADDINT 
+    2811 PUSHACC6 
+    2812 C_CALL3 array_unsafe_set
+    2814 ACC1 
+    2815 OFFSETINT -1
+    2817 ASSIGN 1
+    2819 ACC0 
+    2820 PUSHACC2 
+    2821 GEINT 
+    2822 BRANCHIF 2801
+    2824 CONST0 
+    2825 RETURN 7
+    2827 CONST0 
+    2828 PUSHACC5 
+    2829 OFFSETINT -1
+    2831 PUSH 
+    2832 BRANCH 2852
+    2834 CHECK_SIGNALS 
+    2835 ACC1 
+    2836 PUSHACC4 
+    2837 ADDINT 
+    2838 PUSHACC3 
+    2839 C_CALL2 array_unsafe_get
+    2841 PUSHACC2 
+    2842 PUSHACC7 
+    2843 ADDINT 
+    2844 PUSHACC6 
+    2845 C_CALL3 array_unsafe_set
+    2847 ACC1 
+    2848 OFFSETINT 1
+    2850 ASSIGN 1
+    2852 ACC0 
+    2853 PUSHACC2 
+    2854 LEINT 
+    2855 BRANCHIF 2834
+    2857 CONST0 
+    2858 RETURN 7
+    2860 RESTART 
+    2861 GRAB 3
+    2863 CONST0 
+    2864 PUSHACC2 
+    2865 LTINT 
+    2866 BRANCHIF 2881
+    2868 CONST0 
+    2869 PUSHACC3 
+    2870 LTINT 
+    2871 BRANCHIF 2881
+    2873 ACC0 
+    2874 VECTLENGTH 
+    2875 PUSHACC3 
+    2876 PUSHACC3 
+    2877 ADDINT 
+    2878 GTINT 
+    2879 BRANCHIFNOT 2888
+    2881 GETGLOBAL "Array.fill"
+    2883 PUSHGETGLOBALFIELD Pervasives, 2
+    2886 APPTERM1 5
+    2888 ACC1 
+    2889 PUSHACC3 
+    2890 PUSHACC3 
+    2891 ADDINT 
+    2892 OFFSETINT -1
+    2894 PUSH 
+    2895 BRANCH 2908
+    2897 CHECK_SIGNALS 
+    2898 ACC5 
+    2899 PUSHACC2 
+    2900 PUSHACC4 
+    2901 C_CALL3 array_unsafe_set
+    2903 ACC1 
+    2904 OFFSETINT 1
+    2906 ASSIGN 1
+    2908 ACC0 
+    2909 PUSHACC2 
+    2910 LEINT 
+    2911 BRANCHIF 2897
+    2913 CONST0 
+    2914 RETURN 6
+    2916 RESTART 
+    2917 GRAB 2
+    2919 CONST0 
+    2920 PUSHACC2 
+    2921 LTINT 
+    2922 BRANCHIF 2937
+    2924 CONST0 
+    2925 PUSHACC3 
+    2926 LTINT 
+    2927 BRANCHIF 2937
+    2929 ACC0 
+    2930 VECTLENGTH 
+    2931 PUSHACC3 
+    2932 PUSHACC3 
+    2933 ADDINT 
+    2934 GTINT 
+    2935 BRANCHIFNOT 2944
+    2937 GETGLOBAL "Array.sub"
+    2939 PUSHGETGLOBALFIELD Pervasives, 2
+    2942 APPTERM1 4
+    2944 CONST0 
+    2945 PUSHACC3 
+    2946 EQ 
+    2947 BRANCHIFNOT 2952
+    2949 ATOM0 
+    2950 RETURN 3
+    2952 ACC1 
+    2953 PUSHACC1 
+    2954 C_CALL2 array_unsafe_get
+    2956 PUSHACC3 
+    2957 C_CALL2 make_vect
+    2959 PUSHCONST1 
+    2960 PUSHACC4 
+    2961 OFFSETINT -1
+    2963 PUSH 
+    2964 BRANCH 2982
+    2966 CHECK_SIGNALS 
+    2967 ACC1 
+    2968 PUSHACC5 
+    2969 ADDINT 
+    2970 PUSHACC4 
+    2971 C_CALL2 array_unsafe_get
+    2973 PUSHACC2 
+    2974 PUSHACC4 
+    2975 C_CALL3 array_unsafe_set
+    2977 ACC1 
+    2978 OFFSETINT 1
+    2980 ASSIGN 1
+    2982 ACC0 
+    2983 PUSHACC2 
+    2984 LEINT 
+    2985 BRANCHIF 2966
+    2987 CONST0 
+    2988 POP 2
+    2990 ACC0 
+    2991 RETURN 4
+    2993 ACC0 
+    2994 BRANCHIFNOT 3017
+    2996 ACC0 
+    2997 GETFIELD0 
+    2998 PUSHCONST0 
+    2999 PUSHACC1 
+    3000 VECTLENGTH 
+    3001 GTINT 
+    3002 BRANCHIFNOT 3012
+    3004 ENVACC2 
+    3005 PUSHCONST0 
+    3006 PUSHACC2 
+    3007 C_CALL2 array_unsafe_get
+    3009 PUSHENVACC1 
+    3010 APPTERM2 4
+    3012 ACC1 
+    3013 GETFIELD1 
+    3014 PUSHOFFSETCLOSURE0 
+    3015 APPTERM1 3
+    3017 ATOM0 
+    3018 RETURN 1
+    3020 ACC0 
+    3021 PUSHENVACC1 
+    3022 CLOSUREREC 2, 2993
+    3026 ACC1 
+    3027 PUSHACC1 
+    3028 APPTERM1 3
+    3030 CONST0 
+    3031 PUSHACC1 
+    3032 VECTLENGTH 
+    3033 OFFSETINT -1
+    3035 PUSH 
+    3036 BRANCH 3056
+    3038 CHECK_SIGNALS 
+    3039 ACC1 
+    3040 PUSHACC3 
+    3041 C_CALL2 array_unsafe_get
+    3043 PUSHENVACC2 
+    3044 GETFIELD0 
+    3045 PUSHENVACC1 
+    3046 C_CALL3 array_unsafe_set
+    3048 ENVACC2 
+    3049 OFFSETREF 1
+    3051 ACC1 
+    3052 OFFSETINT 1
+    3054 ASSIGN 1
+    3056 ACC0 
+    3057 PUSHACC2 
+    3058 LEINT 
+    3059 BRANCHIF 3038
+    3061 CONST0 
+    3062 RETURN 3
+    3064 RESTART 
+    3065 GRAB 1
+    3067 ACC1 
+    3068 VECTLENGTH 
+    3069 PUSHACC1 
+    3070 ADDINT 
+    3071 RETURN 2
+    3073 RESTART 
+    3074 GRAB 1
+    3076 ACC1 
+    3077 PUSHCONST0 
+    3078 PUSH 
+    3079 CLOSURE 0, 3065
+    3082 PUSHGETGLOBALFIELD List, 12
+    3085 APPLY3 
+    3086 PUSHACC1 
+    3087 PUSHACC1 
+    3088 C_CALL2 make_vect
+    3090 PUSHCONST0 
+    3091 MAKEBLOCK1 0
+    3093 PUSHACC4 
+    3094 PUSHACC1 
+    3095 PUSHACC3 
+    3096 CLOSURE 2, 3030
+    3099 PUSHGETGLOBALFIELD List, 9
+    3102 APPLY2 
+    3103 ACC1 
+    3104 RETURN 5
+    3106 RESTART 
+    3107 GRAB 1
+    3109 ACC0 
+    3110 VECTLENGTH 
+    3111 PUSHACC2 
+    3112 VECTLENGTH 
+    3113 PUSHCONST0 
+    3114 PUSHACC2 
+    3115 EQ 
+    3116 BRANCHIFNOT 3126
+    3118 CONST0 
+    3119 PUSHACC1 
+    3120 EQ 
+    3121 BRANCHIFNOT 3126
+    3123 ATOM0 
+    3124 RETURN 4
+    3126 CONST0 
+    3127 PUSHCONST0 
+    3128 PUSHACC3 
+    3129 GTINT 
+    3130 BRANCHIFNOT 3135
+    3132 ACC3 
+    3133 BRANCH 3136
+    3135 ACC4 
+    3136 C_CALL2 array_unsafe_get
+    3138 PUSHACC1 
+    3139 PUSHACC3 
+    3140 ADDINT 
+    3141 C_CALL2 make_vect
+    3143 PUSHCONST0 
+    3144 PUSHACC3 
+    3145 OFFSETINT -1
+    3147 PUSH 
+    3148 BRANCH 3164
+    3150 CHECK_SIGNALS 
+    3151 ACC1 
+    3152 PUSHACC6 
+    3153 C_CALL2 array_unsafe_get
+    3155 PUSHACC2 
+    3156 PUSHACC4 
+    3157 C_CALL3 array_unsafe_set
+    3159 ACC1 
+    3160 OFFSETINT 1
+    3162 ASSIGN 1
+    3164 ACC0 
+    3165 PUSHACC2 
+    3166 LEINT 
+    3167 BRANCHIF 3150
+    3169 CONST0 
+    3170 POP 2
+    3172 CONST0 
+    3173 PUSHACC2 
+    3174 OFFSETINT -1
+    3176 PUSH 
+    3177 BRANCH 3195
+    3179 CHECK_SIGNALS 
+    3180 ACC1 
+    3181 PUSHACC7 
+    3182 C_CALL2 array_unsafe_get
+    3184 PUSHACC5 
+    3185 PUSHACC3 
+    3186 ADDINT 
+    3187 PUSHACC4 
+    3188 C_CALL3 array_unsafe_set
+    3190 ACC1 
+    3191 OFFSETINT 1
+    3193 ASSIGN 1
+    3195 ACC0 
+    3196 PUSHACC2 
+    3197 LEINT 
+    3198 BRANCHIF 3179
+    3200 CONST0 
+    3201 POP 2
+    3203 ACC0 
+    3204 RETURN 5
+    3206 ACC0 
+    3207 VECTLENGTH 
+    3208 PUSHCONST0 
+    3209 PUSHACC1 
+    3210 EQ 
+    3211 BRANCHIFNOT 3216
+    3213 ATOM0 
+    3214 RETURN 2
+    3216 CONST0 
+    3217 PUSHACC2 
+    3218 C_CALL2 array_unsafe_get
+    3220 PUSHACC1 
+    3221 C_CALL2 make_vect
+    3223 PUSHCONST1 
+    3224 PUSHACC2 
+    3225 OFFSETINT -1
+    3227 PUSH 
+    3228 BRANCH 3244
+    3230 CHECK_SIGNALS 
+    3231 ACC1 
+    3232 PUSHACC5 
+    3233 C_CALL2 array_unsafe_get
+    3235 PUSHACC2 
+    3236 PUSHACC4 
+    3237 C_CALL3 array_unsafe_set
+    3239 ACC1 
+    3240 OFFSETINT 1
+    3242 ASSIGN 1
+    3244 ACC0 
+    3245 PUSHACC2 
+    3246 LEINT 
+    3247 BRANCHIF 3230
+    3249 CONST0 
+    3250 POP 2
+    3252 ACC0 
+    3253 RETURN 3
+    3255 RESTART 
+    3256 GRAB 2
+    3258 ATOM0 
+    3259 PUSHACC1 
+    3260 C_CALL2 make_vect
+    3262 PUSHCONST0 
+    3263 PUSHACC2 
+    3264 OFFSETINT -1
+    3266 PUSH 
+    3267 BRANCH 3282
+    3269 CHECK_SIGNALS 
+    3270 ACC5 
+    3271 PUSHACC5 
+    3272 C_CALL2 make_vect
+    3274 PUSHACC2 
+    3275 PUSHACC4 
+    3276 SETVECTITEM 
+    3277 ACC1 
+    3278 OFFSETINT 1
+    3280 ASSIGN 1
+    3282 ACC0 
+    3283 PUSHACC2 
+    3284 LEINT 
+    3285 BRANCHIF 3269
+    3287 CONST0 
+    3288 POP 2
+    3290 ACC0 
+    3291 RETURN 4
+    3293 RESTART 
+    3294 GRAB 1
+    3296 CONST0 
+    3297 PUSHACC1 
+    3298 EQ 
+    3299 BRANCHIFNOT 3304
+    3301 ATOM0 
+    3302 RETURN 2
+    3304 CONST0 
+    3305 PUSHACC2 
+    3306 APPLY1 
+    3307 PUSHACC1 
+    3308 C_CALL2 make_vect
+    3310 PUSHCONST1 
+    3311 PUSHACC2 
+    3312 OFFSETINT -1
+    3314 PUSH 
+    3315 BRANCH 3330
+    3317 CHECK_SIGNALS 
+    3318 ACC1 
+    3319 PUSHACC5 
+    3320 APPLY1 
+    3321 PUSHACC2 
+    3322 PUSHACC4 
+    3323 C_CALL3 array_unsafe_set
+    3325 ACC1 
+    3326 OFFSETINT 1
+    3328 ASSIGN 1
+    3330 ACC0 
+    3331 PUSHACC2 
+    3332 LEINT 
+    3333 BRANCHIF 3317
+    3335 CONST0 
+    3336 POP 2
+    3338 ACC0 
+    3339 RETURN 3
+    3341 CLOSURE 0, 3294
+    3344 PUSH 
+    3345 CLOSURE 0, 3256
+    3348 PUSH 
+    3349 CLOSURE 0, 3206
+    3352 PUSH 
+    3353 CLOSURE 0, 3107
+    3356 PUSH 
+    3357 CLOSURE 0, 3074
+    3360 PUSHACC0 
+    3361 CLOSURE 1, 3020
+    3364 PUSH 
+    3365 CLOSURE 0, 2917
+    3368 PUSH 
+    3369 CLOSURE 0, 2861
+    3372 PUSH 
+    3373 CLOSURE 0, 2749
+    3376 PUSH 
+    3377 CLOSURE 0, 2718
+    3380 PUSH 
+    3381 CLOSURE 0, 2662
+    3384 PUSH 
+    3385 CLOSURE 0, 2630
+    3388 PUSH 
+    3389 CLOSURE 0, 2572
+    3392 PUSH 
+    3393 CLOSURE 0, 2558
+    3396 PUSH 
+    3397 CLOSURE 0, 2505
+    3400 PUSH 
+    3401 CLOSURE 0, 2445
+    3404 PUSH 
+    3405 CLOSURE 0, 2407
+    3408 PUSHACC0 
+    3409 PUSHACC2 
+    3410 PUSHACC6 
+    3411 PUSHACC 8
+    3413 PUSHACC 10
+    3415 PUSHACC 12
+    3417 PUSHACC 8
+    3419 PUSHACC 10
+    3421 PUSHACC 16
+    3423 PUSHACC 18
+    3425 PUSHACC 24
+    3427 PUSHACC 21
+    3429 PUSHACC 23
+    3431 PUSHACC 26
+    3433 PUSHACC 29
+    3435 PUSHACC 30
+    3437 PUSHACC 32
+    3439 MAKEBLOCK 17, 0
+    3442 POP 17
+    3444 SETGLOBAL Array
+    3446 BRANCH 3456
+    3448 ACC0 
+    3449 PUSHENVACC1 
+    3450 GETFIELD0 
+    3451 ADDINT 
+    3452 PUSHENVACC1 
+    3453 SETFIELD0 
+    3454 RETURN 1
+    3456 CONST2 
+    3457 PUSHCONSTINT 200000
+    3459 C_CALL2 make_vect
+    3461 PUSHCONST0 
+    3462 MAKEBLOCK1 0
+    3464 PUSHACC1 
+    3465 PUSHACC1 
+    3466 CLOSURE 1, 3448
+    3469 PUSHGETGLOBALFIELD Array, 11
+    3472 APPLY2 
+    3473 CONSTINT 400000
+    3475 PUSHACC1 
+    3476 GETFIELD0 
+    3477 NEQ 
+    3478 BRANCHIFNOT 3485
+    3480 GETGLOBAL Not_found
+    3482 MAKEBLOCK1 0
+    3484 RAISE 
+    3485 POP 2
+    3487 ATOM0 
+    3488 SETGLOBAL T310-alloc-2
+    3490 STOP 
+**)
diff --git a/test/testinterp/t320-gc-1.ml b/test/testinterp/t320-gc-1.ml
new file mode 100644
index 00000000..4d5d6d96
--- /dev/null
+++ b/test/testinterp/t320-gc-1.ml
@@ -0,0 +1,1589 @@
+open Lib;;
+let rec f n =
+  if n <= 0 then []
+  else n :: f (n-1)
+in
+let l = f 300 in
+Gc.minor ();
+if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 BRANCH 2177
+    1199 RESTART 
+    1200 GRAB 1
+    1202 ACC1 
+    1203 BRANCHIFNOT 1213
+    1205 ACC1 
+    1206 GETFIELD1 
+    1207 PUSHACC1 
+    1208 OFFSETINT 1
+    1210 PUSHOFFSETCLOSURE0 
+    1211 APPTERM2 4
+    1213 ACC0 
+    1214 RETURN 2
+    1216 RESTART 
+    1217 GRAB 1
+    1219 ACC0 
+    1220 BRANCHIFNOT 1251
+    1222 CONST0 
+    1223 PUSHACC2 
+    1224 EQ 
+    1225 BRANCHIFNOT 1231
+    1227 ACC0 
+    1228 GETFIELD0 
+    1229 RETURN 2
+    1231 CONST0 
+    1232 PUSHACC2 
+    1233 GTINT 
+    1234 BRANCHIFNOT 1244
+    1236 ACC1 
+    1237 OFFSETINT -1
+    1239 PUSHACC1 
+    1240 GETFIELD1 
+    1241 PUSHOFFSETCLOSURE0 
+    1242 APPTERM2 4
+    1244 GETGLOBAL "List.nth"
+    1246 PUSHGETGLOBALFIELD Pervasives, 2
+    1249 APPTERM1 3
+    1251 GETGLOBAL "nth"
+    1253 PUSHGETGLOBALFIELD Pervasives, 3
+    1256 APPTERM1 3
+    1258 RESTART 
+    1259 GRAB 1
+    1261 ACC0 
+    1262 BRANCHIFNOT 1274
+    1264 ACC1 
+    1265 PUSHACC1 
+    1266 GETFIELD0 
+    1267 MAKEBLOCK2 0
+    1269 PUSHACC1 
+    1270 GETFIELD1 
+    1271 PUSHOFFSETCLOSURE0 
+    1272 APPTERM2 4
+    1274 ACC1 
+    1275 RETURN 2
+    1277 ACC0 
+    1278 BRANCHIFNOT 1291
+    1280 ACC0 
+    1281 GETFIELD1 
+    1282 PUSHOFFSETCLOSURE0 
+    1283 APPLY1 
+    1284 PUSHACC1 
+    1285 GETFIELD0 
+    1286 PUSHGETGLOBALFIELD Pervasives, 16
+    1289 APPTERM2 3
+    1291 RETURN 1
+    1293 RESTART 
+    1294 GRAB 1
+    1296 ACC1 
+    1297 BRANCHIFNOT 1313
+    1299 ACC1 
+    1300 GETFIELD0 
+    1301 PUSHACC1 
+    1302 APPLY1 
+    1303 PUSHACC2 
+    1304 GETFIELD1 
+    1305 PUSHACC2 
+    1306 PUSHOFFSETCLOSURE0 
+    1307 APPLY2 
+    1308 PUSHACC1 
+    1309 MAKEBLOCK2 0
+    1311 POP 1
+    1313 RETURN 2
+    1315 RESTART 
+    1316 GRAB 1
+    1318 ACC1 
+    1319 BRANCHIFNOT 1331
+    1321 ACC1 
+    1322 GETFIELD0 
+    1323 PUSHACC1 
+    1324 APPLY1 
+    1325 ACC1 
+    1326 GETFIELD1 
+    1327 PUSHACC1 
+    1328 PUSHOFFSETCLOSURE0 
+    1329 APPTERM2 4
+    1331 RETURN 2
+    1333 RESTART 
+    1334 GRAB 2
+    1336 ACC2 
+    1337 BRANCHIFNOT 1350
+    1339 ACC2 
+    1340 GETFIELD1 
+    1341 PUSHACC3 
+    1342 GETFIELD0 
+    1343 PUSHACC3 
+    1344 PUSHACC3 
+    1345 APPLY2 
+    1346 PUSHACC2 
+    1347 PUSHOFFSETCLOSURE0 
+    1348 APPTERM3 6
+    1350 ACC1 
+    1351 RETURN 3
+    1353 RESTART 
+    1354 GRAB 2
+    1356 ACC1 
+    1357 BRANCHIFNOT 1370
+    1359 ACC2 
+    1360 PUSHACC2 
+    1361 GETFIELD1 
+    1362 PUSHACC2 
+    1363 PUSHOFFSETCLOSURE0 
+    1364 APPLY3 
+    1365 PUSHACC2 
+    1366 GETFIELD0 
+    1367 PUSHACC2 
+    1368 APPTERM2 5
+    1370 ACC2 
+    1371 RETURN 3
+    1373 RESTART 
+    1374 GRAB 2
+    1376 ACC1 
+    1377 BRANCHIFNOT 1400
+    1379 ACC2 
+    1380 BRANCHIFNOT 1407
+    1382 ACC2 
+    1383 GETFIELD0 
+    1384 PUSHACC2 
+    1385 GETFIELD0 
+    1386 PUSHACC2 
+    1387 APPLY2 
+    1388 PUSHACC3 
+    1389 GETFIELD1 
+    1390 PUSHACC3 
+    1391 GETFIELD1 
+    1392 PUSHACC3 
+    1393 PUSHOFFSETCLOSURE0 
+    1394 APPLY3 
+    1395 PUSHACC1 
+    1396 MAKEBLOCK2 0
+    1398 RETURN 4
+    1400 ACC2 
+    1401 BRANCHIFNOT 1405
+    1403 BRANCH 1407
+    1405 RETURN 3
+    1407 GETGLOBAL "List.map2"
+    1409 PUSHGETGLOBALFIELD Pervasives, 2
+    1412 APPTERM1 4
+    1414 RESTART 
+    1415 GRAB 2
+    1417 ACC1 
+    1418 BRANCHIFNOT 1437
+    1420 ACC2 
+    1421 BRANCHIFNOT 1444
+    1423 ACC2 
+    1424 GETFIELD0 
+    1425 PUSHACC2 
+    1426 GETFIELD0 
+    1427 PUSHACC2 
+    1428 APPLY2 
+    1429 ACC2 
+    1430 GETFIELD1 
+    1431 PUSHACC2 
+    1432 GETFIELD1 
+    1433 PUSHACC2 
+    1434 PUSHOFFSETCLOSURE0 
+    1435 APPTERM3 6
+    1437 ACC2 
+    1438 BRANCHIFNOT 1442
+    1440 BRANCH 1444
+    1442 RETURN 3
+    1444 GETGLOBAL "List.iter2"
+    1446 PUSHGETGLOBALFIELD Pervasives, 2
+    1449 APPTERM1 4
+    1451 RESTART 
+    1452 GRAB 3
+    1454 ACC2 
+    1455 BRANCHIFNOT 1476
+    1457 ACC3 
+    1458 BRANCHIFNOT 1482
+    1460 ACC3 
+    1461 GETFIELD1 
+    1462 PUSHACC3 
+    1463 GETFIELD1 
+    1464 PUSHACC5 
+    1465 GETFIELD0 
+    1466 PUSHACC5 
+    1467 GETFIELD0 
+    1468 PUSHACC5 
+    1469 PUSHACC5 
+    1470 APPLY3 
+    1471 PUSHACC3 
+    1472 PUSHOFFSETCLOSURE0 
+    1473 APPTERM 4, 8
+    1476 ACC3 
+    1477 BRANCHIF 1482
+    1479 ACC1 
+    1480 RETURN 4
+    1482 GETGLOBAL "List.fold_left2"
+    1484 PUSHGETGLOBALFIELD Pervasives, 2
+    1487 APPTERM1 5
+    1489 RESTART 
+    1490 GRAB 3
+    1492 ACC1 
+    1493 BRANCHIFNOT 1516
+    1495 ACC2 
+    1496 BRANCHIFNOT 1522
+    1498 PUSH_RETADDR 1509
+    1500 ACC6 
+    1501 PUSHACC6 
+    1502 GETFIELD1 
+    1503 PUSHACC6 
+    1504 GETFIELD1 
+    1505 PUSHACC6 
+    1506 PUSHOFFSETCLOSURE0 
+    1507 APPLY 4
+    1509 PUSHACC3 
+    1510 GETFIELD0 
+    1511 PUSHACC3 
+    1512 GETFIELD0 
+    1513 PUSHACC3 
+    1514 APPTERM3 7
+    1516 ACC2 
+    1517 BRANCHIF 1522
+    1519 ACC3 
+    1520 RETURN 4
+    1522 GETGLOBAL "List.fold_right2"
+    1524 PUSHGETGLOBALFIELD Pervasives, 2
+    1527 APPTERM1 5
+    1529 RESTART 
+    1530 GRAB 1
+    1532 ACC1 
+    1533 BRANCHIFNOT 1549
+    1535 ACC1 
+    1536 GETFIELD0 
+    1537 PUSHACC1 
+    1538 APPLY1 
+    1539 BRANCHIFNOT 1547
+    1541 ACC1 
+    1542 GETFIELD1 
+    1543 PUSHACC1 
+    1544 PUSHOFFSETCLOSURE0 
+    1545 APPTERM2 4
+    1547 RETURN 2
+    1549 CONST1 
+    1550 RETURN 2
+    1552 RESTART 
+    1553 GRAB 1
+    1555 ACC1 
+    1556 BRANCHIFNOT 1570
+    1558 ACC1 
+    1559 GETFIELD0 
+    1560 PUSHACC1 
+    1561 APPLY1 
+    1562 BRANCHIF 1570
+    1564 ACC1 
+    1565 GETFIELD1 
+    1566 PUSHACC1 
+    1567 PUSHOFFSETCLOSURE0 
+    1568 APPTERM2 4
+    1570 RETURN 2
+    1572 RESTART 
+    1573 GRAB 2
+    1575 ACC1 
+    1576 BRANCHIFNOT 1599
+    1578 ACC2 
+    1579 BRANCHIFNOT 1605
+    1581 ACC2 
+    1582 GETFIELD0 
+    1583 PUSHACC2 
+    1584 GETFIELD0 
+    1585 PUSHACC2 
+    1586 APPLY2 
+    1587 BRANCHIFNOT 1597
+    1589 ACC2 
+    1590 GETFIELD1 
+    1591 PUSHACC2 
+    1592 GETFIELD1 
+    1593 PUSHACC2 
+    1594 PUSHOFFSETCLOSURE0 
+    1595 APPTERM3 6
+    1597 RETURN 3
+    1599 ACC2 
+    1600 BRANCHIF 1605
+    1602 CONST1 
+    1603 RETURN 3
+    1605 GETGLOBAL "List.for_all2"
+    1607 PUSHGETGLOBALFIELD Pervasives, 2
+    1610 APPTERM1 4
+    1612 RESTART 
+    1613 GRAB 2
+    1615 ACC1 
+    1616 BRANCHIFNOT 1639
+    1618 ACC2 
+    1619 BRANCHIFNOT 1646
+    1621 ACC2 
+    1622 GETFIELD0 
+    1623 PUSHACC2 
+    1624 GETFIELD0 
+    1625 PUSHACC2 
+    1626 APPLY2 
+    1627 BRANCHIF 1637
+    1629 ACC2 
+    1630 GETFIELD1 
+    1631 PUSHACC2 
+    1632 GETFIELD1 
+    1633 PUSHACC2 
+    1634 PUSHOFFSETCLOSURE0 
+    1635 APPTERM3 6
+    1637 RETURN 3
+    1639 ACC2 
+    1640 BRANCHIFNOT 1644
+    1642 BRANCH 1646
+    1644 RETURN 3
+    1646 GETGLOBAL "List.exists2"
+    1648 PUSHGETGLOBALFIELD Pervasives, 2
+    1651 APPTERM1 4
+    1653 RESTART 
+    1654 GRAB 1
+    1656 ACC1 
+    1657 BRANCHIFNOT 1672
+    1659 ACC0 
+    1660 PUSHACC2 
+    1661 GETFIELD0 
+    1662 C_CALL2 equal
+    1664 BRANCHIF 1672
+    1666 ACC1 
+    1667 GETFIELD1 
+    1668 PUSHACC1 
+    1669 PUSHOFFSETCLOSURE0 
+    1670 APPTERM2 4
+    1672 RETURN 2
+    1674 RESTART 
+    1675 GRAB 1
+    1677 ACC1 
+    1678 BRANCHIFNOT 1692
+    1680 ACC0 
+    1681 PUSHACC2 
+    1682 GETFIELD0 
+    1683 EQ 
+    1684 BRANCHIF 1692
+    1686 ACC1 
+    1687 GETFIELD1 
+    1688 PUSHACC1 
+    1689 PUSHOFFSETCLOSURE0 
+    1690 APPTERM2 4
+    1692 RETURN 2
+    1694 RESTART 
+    1695 GRAB 1
+    1697 ACC1 
+    1698 BRANCHIFNOT 1719
+    1700 ACC1 
+    1701 GETFIELD0 
+    1702 PUSHACC1 
+    1703 PUSHACC1 
+    1704 GETFIELD0 
+    1705 C_CALL2 equal
+    1707 BRANCHIFNOT 1713
+    1709 ACC0 
+    1710 GETFIELD1 
+    1711 RETURN 3
+    1713 ACC2 
+    1714 GETFIELD1 
+    1715 PUSHACC2 
+    1716 PUSHOFFSETCLOSURE0 
+    1717 APPTERM2 5
+    1719 GETGLOBAL Not_found
+    1721 MAKEBLOCK1 0
+    1723 RAISE 
+    1724 RESTART 
+    1725 GRAB 1
+    1727 ACC1 
+    1728 BRANCHIFNOT 1748
+    1730 ACC1 
+    1731 GETFIELD0 
+    1732 PUSHACC1 
+    1733 PUSHACC1 
+    1734 GETFIELD0 
+    1735 EQ 
+    1736 BRANCHIFNOT 1742
+    1738 ACC0 
+    1739 GETFIELD1 
+    1740 RETURN 3
+    1742 ACC2 
+    1743 GETFIELD1 
+    1744 PUSHACC2 
+    1745 PUSHOFFSETCLOSURE0 
+    1746 APPTERM2 5
+    1748 GETGLOBAL Not_found
+    1750 MAKEBLOCK1 0
+    1752 RAISE 
+    1753 RESTART 
+    1754 GRAB 1
+    1756 ACC1 
+    1757 BRANCHIFNOT 1773
+    1759 ACC0 
+    1760 PUSHACC2 
+    1761 GETFIELD0 
+    1762 GETFIELD0 
+    1763 C_CALL2 equal
+    1765 BRANCHIF 1773
+    1767 ACC1 
+    1768 GETFIELD1 
+    1769 PUSHACC1 
+    1770 PUSHOFFSETCLOSURE0 
+    1771 APPTERM2 4
+    1773 RETURN 2
+    1775 RESTART 
+    1776 GRAB 1
+    1778 ACC1 
+    1779 BRANCHIFNOT 1794
+    1781 ACC0 
+    1782 PUSHACC2 
+    1783 GETFIELD0 
+    1784 GETFIELD0 
+    1785 EQ 
+    1786 BRANCHIF 1794
+    1788 ACC1 
+    1789 GETFIELD1 
+    1790 PUSHACC1 
+    1791 PUSHOFFSETCLOSURE0 
+    1792 APPTERM2 4
+    1794 RETURN 2
+    1796 RESTART 
+    1797 GRAB 1
+    1799 ACC1 
+    1800 BRANCHIFNOT 1825
+    1802 ACC1 
+    1803 GETFIELD0 
+    1804 PUSHACC2 
+    1805 GETFIELD1 
+    1806 PUSHACC2 
+    1807 PUSHACC2 
+    1808 GETFIELD0 
+    1809 C_CALL2 equal
+    1811 BRANCHIFNOT 1816
+    1813 ACC0 
+    1814 RETURN 4
+    1816 ACC0 
+    1817 PUSHACC3 
+    1818 PUSHOFFSETCLOSURE0 
+    1819 APPLY2 
+    1820 PUSHACC2 
+    1821 MAKEBLOCK2 0
+    1823 POP 2
+    1825 RETURN 2
+    1827 RESTART 
+    1828 GRAB 1
+    1830 ACC1 
+    1831 BRANCHIFNOT 1855
+    1833 ACC1 
+    1834 GETFIELD0 
+    1835 PUSHACC2 
+    1836 GETFIELD1 
+    1837 PUSHACC2 
+    1838 PUSHACC2 
+    1839 GETFIELD0 
+    1840 EQ 
+    1841 BRANCHIFNOT 1846
+    1843 ACC0 
+    1844 RETURN 4
+    1846 ACC0 
+    1847 PUSHACC3 
+    1848 PUSHOFFSETCLOSURE0 
+    1849 APPLY2 
+    1850 PUSHACC2 
+    1851 MAKEBLOCK2 0
+    1853 POP 2
+    1855 RETURN 2
+    1857 RESTART 
+    1858 GRAB 1
+    1860 ACC1 
+    1861 BRANCHIFNOT 1879
+    1863 ACC1 
+    1864 GETFIELD0 
+    1865 PUSHACC0 
+    1866 PUSHACC2 
+    1867 APPLY1 
+    1868 BRANCHIFNOT 1873
+    1870 ACC0 
+    1871 RETURN 3
+    1873 ACC2 
+    1874 GETFIELD1 
+    1875 PUSHACC2 
+    1876 PUSHOFFSETCLOSURE0 
+    1877 APPTERM2 5
+    1879 GETGLOBAL Not_found
+    1881 MAKEBLOCK1 0
+    1883 RAISE 
+    1884 RESTART 
+    1885 GRAB 2
+    1887 ACC2 
+    1888 BRANCHIFNOT 1917
+    1890 ACC2 
+    1891 GETFIELD0 
+    1892 PUSHACC3 
+    1893 GETFIELD1 
+    1894 PUSHACC1 
+    1895 PUSHENVACC2 
+    1896 APPLY1 
+    1897 BRANCHIFNOT 1908
+    1899 ACC0 
+    1900 PUSHACC4 
+    1901 PUSHACC4 
+    1902 PUSHACC4 
+    1903 MAKEBLOCK2 0
+    1905 PUSHOFFSETCLOSURE0 
+    1906 APPTERM3 8
+    1908 ACC0 
+    1909 PUSHACC4 
+    1910 PUSHACC3 
+    1911 MAKEBLOCK2 0
+    1913 PUSHACC4 
+    1914 PUSHOFFSETCLOSURE0 
+    1915 APPTERM3 8
+    1917 ACC1 
+    1918 PUSHENVACC1 
+    1919 APPLY1 
+    1920 PUSHACC1 
+    1921 PUSHENVACC1 
+    1922 APPLY1 
+    1923 MAKEBLOCK2 0
+    1925 RETURN 3
+    1927 RESTART 
+    1928 GRAB 1
+    1930 ACC0 
+    1931 PUSHENVACC1 
+    1932 CLOSUREREC 2, 1885
+    1936 ACC2 
+    1937 PUSHCONST0 
+    1938 PUSHCONST0 
+    1939 PUSHACC3 
+    1940 APPTERM3 6
+    1942 ACC0 
+    1943 BRANCHIFNOT 1967
+    1945 ACC0 
+    1946 GETFIELD0 
+    1947 PUSHACC1 
+    1948 GETFIELD1 
+    1949 PUSHOFFSETCLOSURE0 
+    1950 APPLY1 
+    1951 PUSHACC0 
+    1952 GETFIELD1 
+    1953 PUSHACC2 
+    1954 GETFIELD1 
+    1955 MAKEBLOCK2 0
+    1957 PUSHACC1 
+    1958 GETFIELD0 
+    1959 PUSHACC3 
+    1960 GETFIELD0 
+    1961 MAKEBLOCK2 0
+    1963 MAKEBLOCK2 0
+    1965 RETURN 3
+    1967 GETGLOBAL <0>(0, 0)
+    1969 RETURN 1
+    1971 RESTART 
+    1972 GRAB 1
+    1974 ACC0 
+    1975 BRANCHIFNOT 1996
+    1977 ACC1 
+    1978 BRANCHIFNOT 2003
+    1980 ACC1 
+    1981 GETFIELD1 
+    1982 PUSHACC1 
+    1983 GETFIELD1 
+    1984 PUSHOFFSETCLOSURE0 
+    1985 APPLY2 
+    1986 PUSHACC2 
+    1987 GETFIELD0 
+    1988 PUSHACC2 
+    1989 GETFIELD0 
+    1990 MAKEBLOCK2 0
+    1992 MAKEBLOCK2 0
+    1994 RETURN 2
+    1996 ACC1 
+    1997 BRANCHIFNOT 2001
+    1999 BRANCH 2003
+    2001 RETURN 2
+    2003 GETGLOBAL "List.combine"
+    2005 PUSHGETGLOBALFIELD Pervasives, 2
+    2008 APPTERM1 3
+    2010 RESTART 
+    2011 GRAB 1
+    2013 ACC1 
+    2014 BRANCHIFNOT 2038
+    2016 ACC1 
+    2017 GETFIELD0 
+    2018 PUSHACC2 
+    2019 GETFIELD1 
+    2020 PUSHACC1 
+    2021 PUSHENVACC2 
+    2022 APPLY1 
+    2023 BRANCHIFNOT 2033
+    2025 ACC0 
+    2026 PUSHACC3 
+    2027 PUSHACC3 
+    2028 MAKEBLOCK2 0
+    2030 PUSHOFFSETCLOSURE0 
+    2031 APPTERM2 6
+    2033 ACC0 
+    2034 PUSHACC3 
+    2035 PUSHOFFSETCLOSURE0 
+    2036 APPTERM2 6
+    2038 ACC0 
+    2039 PUSHENVACC1 
+    2040 APPTERM1 3
+    2042 ACC0 
+    2043 PUSHENVACC1 
+    2044 CLOSUREREC 2, 2011
+    2048 CONST0 
+    2049 PUSHACC1 
+    2050 APPTERM1 3
+    2052 RESTART 
+    2053 GRAB 2
+    2055 ACC1 
+    2056 BRANCHIFNOT 2077
+    2058 ACC2 
+    2059 BRANCHIFNOT 2084
+    2061 ACC2 
+    2062 GETFIELD1 
+    2063 PUSHACC2 
+    2064 GETFIELD1 
+    2065 PUSHACC2 
+    2066 PUSHACC5 
+    2067 GETFIELD0 
+    2068 PUSHACC5 
+    2069 GETFIELD0 
+    2070 PUSHENVACC1 
+    2071 APPLY2 
+    2072 MAKEBLOCK2 0
+    2074 PUSHOFFSETCLOSURE0 
+    2075 APPTERM3 6
+    2077 ACC2 
+    2078 BRANCHIFNOT 2082
+    2080 BRANCH 2084
+    2082 RETURN 3
+    2084 GETGLOBAL "List.rev_map2"
+    2086 PUSHGETGLOBALFIELD Pervasives, 2
+    2089 APPTERM1 4
+    2091 RESTART 
+    2092 GRAB 2
+    2094 ACC0 
+    2095 CLOSUREREC 1, 2053
+    2099 ACC3 
+    2100 PUSHACC3 
+    2101 PUSHCONST0 
+    2102 PUSHACC3 
+    2103 APPTERM3 7
+    2105 RESTART 
+    2106 GRAB 1
+    2108 ACC1 
+    2109 BRANCHIFNOT 2123
+    2111 ACC1 
+    2112 GETFIELD1 
+    2113 PUSHACC1 
+    2114 PUSHACC3 
+    2115 GETFIELD0 
+    2116 PUSHENVACC1 
+    2117 APPLY1 
+    2118 MAKEBLOCK2 0
+    2120 PUSHOFFSETCLOSURE0 
+    2121 APPTERM2 4
+    2123 ACC0 
+    2124 RETURN 2
+    2126 RESTART 
+    2127 GRAB 1
+    2129 ACC0 
+    2130 CLOSUREREC 1, 2106
+    2134 ACC2 
+    2135 PUSHCONST0 
+    2136 PUSHACC2 
+    2137 APPTERM2 5
+    2139 CONST0 
+    2140 PUSHACC1 
+    2141 PUSHENVACC1 
+    2142 APPTERM2 3
+    2144 ACC0 
+    2145 BRANCHIFNOT 2151
+    2147 ACC0 
+    2148 GETFIELD1 
+    2149 RETURN 1
+    2151 GETGLOBAL "tl"
+    2153 PUSHGETGLOBALFIELD Pervasives, 3
+    2156 APPTERM1 2
+    2158 ACC0 
+    2159 BRANCHIFNOT 2165
+    2161 ACC0 
+    2162 GETFIELD0 
+    2163 RETURN 1
+    2165 GETGLOBAL "hd"
+    2167 PUSHGETGLOBALFIELD Pervasives, 3
+    2170 APPTERM1 2
+    2172 ACC0 
+    2173 PUSHCONST0 
+    2174 PUSHENVACC1 
+    2175 APPTERM2 3
+    2177 CLOSUREREC 0, 1200
+    2181 ACC0 
+    2182 CLOSURE 1, 2172
+    2185 PUSH 
+    2186 CLOSURE 0, 2158
+    2189 PUSH 
+    2190 CLOSURE 0, 2144
+    2193 PUSH 
+    2194 CLOSUREREC 0, 1217
+    2198 GETGLOBALFIELD Pervasives, 16
+    2201 PUSH 
+    2202 CLOSUREREC 0, 1259
+    2206 ACC0 
+    2207 CLOSURE 1, 2139
+    2210 PUSH 
+    2211 CLOSUREREC 0, 1277
+    2215 CLOSUREREC 0, 1294
+    2219 CLOSURE 0, 2127
+    2222 PUSH 
+    2223 CLOSUREREC 0, 1316
+    2227 CLOSUREREC 0, 1334
+    2231 CLOSUREREC 0, 1354
+    2235 CLOSUREREC 0, 1374
+    2239 CLOSURE 0, 2092
+    2242 PUSH 
+    2243 CLOSUREREC 0, 1415
+    2247 CLOSUREREC 0, 1452
+    2251 CLOSUREREC 0, 1490
+    2255 CLOSUREREC 0, 1530
+    2259 CLOSUREREC 0, 1553
+    2263 CLOSUREREC 0, 1573
+    2267 CLOSUREREC 0, 1613
+    2271 CLOSUREREC 0, 1654
+    2275 CLOSUREREC 0, 1675
+    2279 CLOSUREREC 0, 1695
+    2283 CLOSUREREC 0, 1725
+    2287 CLOSUREREC 0, 1754
+    2291 CLOSUREREC 0, 1776
+    2295 CLOSUREREC 0, 1797
+    2299 CLOSUREREC 0, 1828
+    2303 CLOSUREREC 0, 1858
+    2307 ACC 24
+    2309 CLOSURE 1, 2042
+    2312 PUSHACC 25
+    2314 CLOSUREREC 1, 1928
+    2318 CLOSUREREC 0, 1942
+    2322 CLOSUREREC 0, 1972
+    2326 ACC0 
+    2327 PUSHACC2 
+    2328 PUSHACC7 
+    2329 PUSHACC 9
+    2331 PUSHACC 11
+    2333 PUSHACC 13
+    2335 PUSHACC 15
+    2337 PUSHACC 17
+    2339 PUSHACC 10
+    2341 PUSHACC 12
+    2343 PUSHACC 13
+    2345 PUSHACC 15
+    2347 PUSHACC 23
+    2349 PUSHACC 25
+    2351 PUSHACC 27
+    2353 PUSHACC 29
+    2355 PUSHACC 31
+    2357 PUSHACC 33
+    2359 PUSHACC 35
+    2361 PUSHACC 37
+    2363 PUSHACC 40
+    2365 PUSHACC 42
+    2367 PUSHACC 41
+    2369 PUSHACC 45
+    2371 PUSHACC 47
+    2373 PUSHACC 50
+    2375 PUSHACC 52
+    2377 PUSHACC 51
+    2379 PUSHACC 55
+    2381 PUSHACC 56
+    2383 PUSHACC 59
+    2385 PUSHACC 61
+    2387 PUSHACC 60
+    2389 PUSHACC 64
+    2391 PUSHACC 66
+    2393 PUSHACC 68
+    2395 PUSHACC 70
+    2397 MAKEBLOCK 37, 0
+    2400 POP 36
+    2402 SETGLOBAL List
+    2404 BRANCH 2432
+    2406 CONST0 
+    2407 PUSHACC1 
+    2408 LEINT 
+    2409 BRANCHIFNOT 2414
+    2411 CONST0 
+    2412 RETURN 1
+    2414 ACC0 
+    2415 OFFSETINT -1
+    2417 PUSHOFFSETCLOSURE0 
+    2418 APPLY1 
+    2419 PUSHACC1 
+    2420 MAKEBLOCK2 0
+    2422 RETURN 1
+    2424 RESTART 
+    2425 GRAB 1
+    2427 ACC1 
+    2428 PUSHACC1 
+    2429 ADDINT 
+    2430 RETURN 2
+    2432 CLOSUREREC 0, 2406
+    2436 CONSTINT 300
+    2438 PUSHACC1 
+    2439 APPLY1 
+    2440 PUSHCONST0 
+    2441 C_CALL1 gc_minor
+    2443 CONSTINT 150
+    2445 PUSHCONSTINT 301
+    2447 MULINT 
+    2448 PUSHACC1 
+    2449 PUSHCONST0 
+    2450 PUSH 
+    2451 CLOSURE 0, 2425
+    2454 PUSHGETGLOBALFIELD List, 12
+    2457 APPLY3 
+    2458 NEQ 
+    2459 BRANCHIFNOT 2466
+    2461 GETGLOBAL Not_found
+    2463 MAKEBLOCK1 0
+    2465 RAISE 
+    2466 POP 2
+    2468 ATOM0 
+    2469 SETGLOBAL T320-gc-1
+    2471 STOP 
+**)
diff --git a/test/testinterp/t320-gc-2.ml b/test/testinterp/t320-gc-2.ml
new file mode 100644
index 00000000..f607f651
--- /dev/null
+++ b/test/testinterp/t320-gc-2.ml
@@ -0,0 +1,1589 @@
+open Lib;;
+let rec f n =
+  if n <= 0 then []
+  else n :: f (n-1)
+in
+let l = f 300 in
+Gc.major ();
+if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 BRANCH 2177
+    1199 RESTART 
+    1200 GRAB 1
+    1202 ACC1 
+    1203 BRANCHIFNOT 1213
+    1205 ACC1 
+    1206 GETFIELD1 
+    1207 PUSHACC1 
+    1208 OFFSETINT 1
+    1210 PUSHOFFSETCLOSURE0 
+    1211 APPTERM2 4
+    1213 ACC0 
+    1214 RETURN 2
+    1216 RESTART 
+    1217 GRAB 1
+    1219 ACC0 
+    1220 BRANCHIFNOT 1251
+    1222 CONST0 
+    1223 PUSHACC2 
+    1224 EQ 
+    1225 BRANCHIFNOT 1231
+    1227 ACC0 
+    1228 GETFIELD0 
+    1229 RETURN 2
+    1231 CONST0 
+    1232 PUSHACC2 
+    1233 GTINT 
+    1234 BRANCHIFNOT 1244
+    1236 ACC1 
+    1237 OFFSETINT -1
+    1239 PUSHACC1 
+    1240 GETFIELD1 
+    1241 PUSHOFFSETCLOSURE0 
+    1242 APPTERM2 4
+    1244 GETGLOBAL "List.nth"
+    1246 PUSHGETGLOBALFIELD Pervasives, 2
+    1249 APPTERM1 3
+    1251 GETGLOBAL "nth"
+    1253 PUSHGETGLOBALFIELD Pervasives, 3
+    1256 APPTERM1 3
+    1258 RESTART 
+    1259 GRAB 1
+    1261 ACC0 
+    1262 BRANCHIFNOT 1274
+    1264 ACC1 
+    1265 PUSHACC1 
+    1266 GETFIELD0 
+    1267 MAKEBLOCK2 0
+    1269 PUSHACC1 
+    1270 GETFIELD1 
+    1271 PUSHOFFSETCLOSURE0 
+    1272 APPTERM2 4
+    1274 ACC1 
+    1275 RETURN 2
+    1277 ACC0 
+    1278 BRANCHIFNOT 1291
+    1280 ACC0 
+    1281 GETFIELD1 
+    1282 PUSHOFFSETCLOSURE0 
+    1283 APPLY1 
+    1284 PUSHACC1 
+    1285 GETFIELD0 
+    1286 PUSHGETGLOBALFIELD Pervasives, 16
+    1289 APPTERM2 3
+    1291 RETURN 1
+    1293 RESTART 
+    1294 GRAB 1
+    1296 ACC1 
+    1297 BRANCHIFNOT 1313
+    1299 ACC1 
+    1300 GETFIELD0 
+    1301 PUSHACC1 
+    1302 APPLY1 
+    1303 PUSHACC2 
+    1304 GETFIELD1 
+    1305 PUSHACC2 
+    1306 PUSHOFFSETCLOSURE0 
+    1307 APPLY2 
+    1308 PUSHACC1 
+    1309 MAKEBLOCK2 0
+    1311 POP 1
+    1313 RETURN 2
+    1315 RESTART 
+    1316 GRAB 1
+    1318 ACC1 
+    1319 BRANCHIFNOT 1331
+    1321 ACC1 
+    1322 GETFIELD0 
+    1323 PUSHACC1 
+    1324 APPLY1 
+    1325 ACC1 
+    1326 GETFIELD1 
+    1327 PUSHACC1 
+    1328 PUSHOFFSETCLOSURE0 
+    1329 APPTERM2 4
+    1331 RETURN 2
+    1333 RESTART 
+    1334 GRAB 2
+    1336 ACC2 
+    1337 BRANCHIFNOT 1350
+    1339 ACC2 
+    1340 GETFIELD1 
+    1341 PUSHACC3 
+    1342 GETFIELD0 
+    1343 PUSHACC3 
+    1344 PUSHACC3 
+    1345 APPLY2 
+    1346 PUSHACC2 
+    1347 PUSHOFFSETCLOSURE0 
+    1348 APPTERM3 6
+    1350 ACC1 
+    1351 RETURN 3
+    1353 RESTART 
+    1354 GRAB 2
+    1356 ACC1 
+    1357 BRANCHIFNOT 1370
+    1359 ACC2 
+    1360 PUSHACC2 
+    1361 GETFIELD1 
+    1362 PUSHACC2 
+    1363 PUSHOFFSETCLOSURE0 
+    1364 APPLY3 
+    1365 PUSHACC2 
+    1366 GETFIELD0 
+    1367 PUSHACC2 
+    1368 APPTERM2 5
+    1370 ACC2 
+    1371 RETURN 3
+    1373 RESTART 
+    1374 GRAB 2
+    1376 ACC1 
+    1377 BRANCHIFNOT 1400
+    1379 ACC2 
+    1380 BRANCHIFNOT 1407
+    1382 ACC2 
+    1383 GETFIELD0 
+    1384 PUSHACC2 
+    1385 GETFIELD0 
+    1386 PUSHACC2 
+    1387 APPLY2 
+    1388 PUSHACC3 
+    1389 GETFIELD1 
+    1390 PUSHACC3 
+    1391 GETFIELD1 
+    1392 PUSHACC3 
+    1393 PUSHOFFSETCLOSURE0 
+    1394 APPLY3 
+    1395 PUSHACC1 
+    1396 MAKEBLOCK2 0
+    1398 RETURN 4
+    1400 ACC2 
+    1401 BRANCHIFNOT 1405
+    1403 BRANCH 1407
+    1405 RETURN 3
+    1407 GETGLOBAL "List.map2"
+    1409 PUSHGETGLOBALFIELD Pervasives, 2
+    1412 APPTERM1 4
+    1414 RESTART 
+    1415 GRAB 2
+    1417 ACC1 
+    1418 BRANCHIFNOT 1437
+    1420 ACC2 
+    1421 BRANCHIFNOT 1444
+    1423 ACC2 
+    1424 GETFIELD0 
+    1425 PUSHACC2 
+    1426 GETFIELD0 
+    1427 PUSHACC2 
+    1428 APPLY2 
+    1429 ACC2 
+    1430 GETFIELD1 
+    1431 PUSHACC2 
+    1432 GETFIELD1 
+    1433 PUSHACC2 
+    1434 PUSHOFFSETCLOSURE0 
+    1435 APPTERM3 6
+    1437 ACC2 
+    1438 BRANCHIFNOT 1442
+    1440 BRANCH 1444
+    1442 RETURN 3
+    1444 GETGLOBAL "List.iter2"
+    1446 PUSHGETGLOBALFIELD Pervasives, 2
+    1449 APPTERM1 4
+    1451 RESTART 
+    1452 GRAB 3
+    1454 ACC2 
+    1455 BRANCHIFNOT 1476
+    1457 ACC3 
+    1458 BRANCHIFNOT 1482
+    1460 ACC3 
+    1461 GETFIELD1 
+    1462 PUSHACC3 
+    1463 GETFIELD1 
+    1464 PUSHACC5 
+    1465 GETFIELD0 
+    1466 PUSHACC5 
+    1467 GETFIELD0 
+    1468 PUSHACC5 
+    1469 PUSHACC5 
+    1470 APPLY3 
+    1471 PUSHACC3 
+    1472 PUSHOFFSETCLOSURE0 
+    1473 APPTERM 4, 8
+    1476 ACC3 
+    1477 BRANCHIF 1482
+    1479 ACC1 
+    1480 RETURN 4
+    1482 GETGLOBAL "List.fold_left2"
+    1484 PUSHGETGLOBALFIELD Pervasives, 2
+    1487 APPTERM1 5
+    1489 RESTART 
+    1490 GRAB 3
+    1492 ACC1 
+    1493 BRANCHIFNOT 1516
+    1495 ACC2 
+    1496 BRANCHIFNOT 1522
+    1498 PUSH_RETADDR 1509
+    1500 ACC6 
+    1501 PUSHACC6 
+    1502 GETFIELD1 
+    1503 PUSHACC6 
+    1504 GETFIELD1 
+    1505 PUSHACC6 
+    1506 PUSHOFFSETCLOSURE0 
+    1507 APPLY 4
+    1509 PUSHACC3 
+    1510 GETFIELD0 
+    1511 PUSHACC3 
+    1512 GETFIELD0 
+    1513 PUSHACC3 
+    1514 APPTERM3 7
+    1516 ACC2 
+    1517 BRANCHIF 1522
+    1519 ACC3 
+    1520 RETURN 4
+    1522 GETGLOBAL "List.fold_right2"
+    1524 PUSHGETGLOBALFIELD Pervasives, 2
+    1527 APPTERM1 5
+    1529 RESTART 
+    1530 GRAB 1
+    1532 ACC1 
+    1533 BRANCHIFNOT 1549
+    1535 ACC1 
+    1536 GETFIELD0 
+    1537 PUSHACC1 
+    1538 APPLY1 
+    1539 BRANCHIFNOT 1547
+    1541 ACC1 
+    1542 GETFIELD1 
+    1543 PUSHACC1 
+    1544 PUSHOFFSETCLOSURE0 
+    1545 APPTERM2 4
+    1547 RETURN 2
+    1549 CONST1 
+    1550 RETURN 2
+    1552 RESTART 
+    1553 GRAB 1
+    1555 ACC1 
+    1556 BRANCHIFNOT 1570
+    1558 ACC1 
+    1559 GETFIELD0 
+    1560 PUSHACC1 
+    1561 APPLY1 
+    1562 BRANCHIF 1570
+    1564 ACC1 
+    1565 GETFIELD1 
+    1566 PUSHACC1 
+    1567 PUSHOFFSETCLOSURE0 
+    1568 APPTERM2 4
+    1570 RETURN 2
+    1572 RESTART 
+    1573 GRAB 2
+    1575 ACC1 
+    1576 BRANCHIFNOT 1599
+    1578 ACC2 
+    1579 BRANCHIFNOT 1605
+    1581 ACC2 
+    1582 GETFIELD0 
+    1583 PUSHACC2 
+    1584 GETFIELD0 
+    1585 PUSHACC2 
+    1586 APPLY2 
+    1587 BRANCHIFNOT 1597
+    1589 ACC2 
+    1590 GETFIELD1 
+    1591 PUSHACC2 
+    1592 GETFIELD1 
+    1593 PUSHACC2 
+    1594 PUSHOFFSETCLOSURE0 
+    1595 APPTERM3 6
+    1597 RETURN 3
+    1599 ACC2 
+    1600 BRANCHIF 1605
+    1602 CONST1 
+    1603 RETURN 3
+    1605 GETGLOBAL "List.for_all2"
+    1607 PUSHGETGLOBALFIELD Pervasives, 2
+    1610 APPTERM1 4
+    1612 RESTART 
+    1613 GRAB 2
+    1615 ACC1 
+    1616 BRANCHIFNOT 1639
+    1618 ACC2 
+    1619 BRANCHIFNOT 1646
+    1621 ACC2 
+    1622 GETFIELD0 
+    1623 PUSHACC2 
+    1624 GETFIELD0 
+    1625 PUSHACC2 
+    1626 APPLY2 
+    1627 BRANCHIF 1637
+    1629 ACC2 
+    1630 GETFIELD1 
+    1631 PUSHACC2 
+    1632 GETFIELD1 
+    1633 PUSHACC2 
+    1634 PUSHOFFSETCLOSURE0 
+    1635 APPTERM3 6
+    1637 RETURN 3
+    1639 ACC2 
+    1640 BRANCHIFNOT 1644
+    1642 BRANCH 1646
+    1644 RETURN 3
+    1646 GETGLOBAL "List.exists2"
+    1648 PUSHGETGLOBALFIELD Pervasives, 2
+    1651 APPTERM1 4
+    1653 RESTART 
+    1654 GRAB 1
+    1656 ACC1 
+    1657 BRANCHIFNOT 1672
+    1659 ACC0 
+    1660 PUSHACC2 
+    1661 GETFIELD0 
+    1662 C_CALL2 equal
+    1664 BRANCHIF 1672
+    1666 ACC1 
+    1667 GETFIELD1 
+    1668 PUSHACC1 
+    1669 PUSHOFFSETCLOSURE0 
+    1670 APPTERM2 4
+    1672 RETURN 2
+    1674 RESTART 
+    1675 GRAB 1
+    1677 ACC1 
+    1678 BRANCHIFNOT 1692
+    1680 ACC0 
+    1681 PUSHACC2 
+    1682 GETFIELD0 
+    1683 EQ 
+    1684 BRANCHIF 1692
+    1686 ACC1 
+    1687 GETFIELD1 
+    1688 PUSHACC1 
+    1689 PUSHOFFSETCLOSURE0 
+    1690 APPTERM2 4
+    1692 RETURN 2
+    1694 RESTART 
+    1695 GRAB 1
+    1697 ACC1 
+    1698 BRANCHIFNOT 1719
+    1700 ACC1 
+    1701 GETFIELD0 
+    1702 PUSHACC1 
+    1703 PUSHACC1 
+    1704 GETFIELD0 
+    1705 C_CALL2 equal
+    1707 BRANCHIFNOT 1713
+    1709 ACC0 
+    1710 GETFIELD1 
+    1711 RETURN 3
+    1713 ACC2 
+    1714 GETFIELD1 
+    1715 PUSHACC2 
+    1716 PUSHOFFSETCLOSURE0 
+    1717 APPTERM2 5
+    1719 GETGLOBAL Not_found
+    1721 MAKEBLOCK1 0
+    1723 RAISE 
+    1724 RESTART 
+    1725 GRAB 1
+    1727 ACC1 
+    1728 BRANCHIFNOT 1748
+    1730 ACC1 
+    1731 GETFIELD0 
+    1732 PUSHACC1 
+    1733 PUSHACC1 
+    1734 GETFIELD0 
+    1735 EQ 
+    1736 BRANCHIFNOT 1742
+    1738 ACC0 
+    1739 GETFIELD1 
+    1740 RETURN 3
+    1742 ACC2 
+    1743 GETFIELD1 
+    1744 PUSHACC2 
+    1745 PUSHOFFSETCLOSURE0 
+    1746 APPTERM2 5
+    1748 GETGLOBAL Not_found
+    1750 MAKEBLOCK1 0
+    1752 RAISE 
+    1753 RESTART 
+    1754 GRAB 1
+    1756 ACC1 
+    1757 BRANCHIFNOT 1773
+    1759 ACC0 
+    1760 PUSHACC2 
+    1761 GETFIELD0 
+    1762 GETFIELD0 
+    1763 C_CALL2 equal
+    1765 BRANCHIF 1773
+    1767 ACC1 
+    1768 GETFIELD1 
+    1769 PUSHACC1 
+    1770 PUSHOFFSETCLOSURE0 
+    1771 APPTERM2 4
+    1773 RETURN 2
+    1775 RESTART 
+    1776 GRAB 1
+    1778 ACC1 
+    1779 BRANCHIFNOT 1794
+    1781 ACC0 
+    1782 PUSHACC2 
+    1783 GETFIELD0 
+    1784 GETFIELD0 
+    1785 EQ 
+    1786 BRANCHIF 1794
+    1788 ACC1 
+    1789 GETFIELD1 
+    1790 PUSHACC1 
+    1791 PUSHOFFSETCLOSURE0 
+    1792 APPTERM2 4
+    1794 RETURN 2
+    1796 RESTART 
+    1797 GRAB 1
+    1799 ACC1 
+    1800 BRANCHIFNOT 1825
+    1802 ACC1 
+    1803 GETFIELD0 
+    1804 PUSHACC2 
+    1805 GETFIELD1 
+    1806 PUSHACC2 
+    1807 PUSHACC2 
+    1808 GETFIELD0 
+    1809 C_CALL2 equal
+    1811 BRANCHIFNOT 1816
+    1813 ACC0 
+    1814 RETURN 4
+    1816 ACC0 
+    1817 PUSHACC3 
+    1818 PUSHOFFSETCLOSURE0 
+    1819 APPLY2 
+    1820 PUSHACC2 
+    1821 MAKEBLOCK2 0
+    1823 POP 2
+    1825 RETURN 2
+    1827 RESTART 
+    1828 GRAB 1
+    1830 ACC1 
+    1831 BRANCHIFNOT 1855
+    1833 ACC1 
+    1834 GETFIELD0 
+    1835 PUSHACC2 
+    1836 GETFIELD1 
+    1837 PUSHACC2 
+    1838 PUSHACC2 
+    1839 GETFIELD0 
+    1840 EQ 
+    1841 BRANCHIFNOT 1846
+    1843 ACC0 
+    1844 RETURN 4
+    1846 ACC0 
+    1847 PUSHACC3 
+    1848 PUSHOFFSETCLOSURE0 
+    1849 APPLY2 
+    1850 PUSHACC2 
+    1851 MAKEBLOCK2 0
+    1853 POP 2
+    1855 RETURN 2
+    1857 RESTART 
+    1858 GRAB 1
+    1860 ACC1 
+    1861 BRANCHIFNOT 1879
+    1863 ACC1 
+    1864 GETFIELD0 
+    1865 PUSHACC0 
+    1866 PUSHACC2 
+    1867 APPLY1 
+    1868 BRANCHIFNOT 1873
+    1870 ACC0 
+    1871 RETURN 3
+    1873 ACC2 
+    1874 GETFIELD1 
+    1875 PUSHACC2 
+    1876 PUSHOFFSETCLOSURE0 
+    1877 APPTERM2 5
+    1879 GETGLOBAL Not_found
+    1881 MAKEBLOCK1 0
+    1883 RAISE 
+    1884 RESTART 
+    1885 GRAB 2
+    1887 ACC2 
+    1888 BRANCHIFNOT 1917
+    1890 ACC2 
+    1891 GETFIELD0 
+    1892 PUSHACC3 
+    1893 GETFIELD1 
+    1894 PUSHACC1 
+    1895 PUSHENVACC2 
+    1896 APPLY1 
+    1897 BRANCHIFNOT 1908
+    1899 ACC0 
+    1900 PUSHACC4 
+    1901 PUSHACC4 
+    1902 PUSHACC4 
+    1903 MAKEBLOCK2 0
+    1905 PUSHOFFSETCLOSURE0 
+    1906 APPTERM3 8
+    1908 ACC0 
+    1909 PUSHACC4 
+    1910 PUSHACC3 
+    1911 MAKEBLOCK2 0
+    1913 PUSHACC4 
+    1914 PUSHOFFSETCLOSURE0 
+    1915 APPTERM3 8
+    1917 ACC1 
+    1918 PUSHENVACC1 
+    1919 APPLY1 
+    1920 PUSHACC1 
+    1921 PUSHENVACC1 
+    1922 APPLY1 
+    1923 MAKEBLOCK2 0
+    1925 RETURN 3
+    1927 RESTART 
+    1928 GRAB 1
+    1930 ACC0 
+    1931 PUSHENVACC1 
+    1932 CLOSUREREC 2, 1885
+    1936 ACC2 
+    1937 PUSHCONST0 
+    1938 PUSHCONST0 
+    1939 PUSHACC3 
+    1940 APPTERM3 6
+    1942 ACC0 
+    1943 BRANCHIFNOT 1967
+    1945 ACC0 
+    1946 GETFIELD0 
+    1947 PUSHACC1 
+    1948 GETFIELD1 
+    1949 PUSHOFFSETCLOSURE0 
+    1950 APPLY1 
+    1951 PUSHACC0 
+    1952 GETFIELD1 
+    1953 PUSHACC2 
+    1954 GETFIELD1 
+    1955 MAKEBLOCK2 0
+    1957 PUSHACC1 
+    1958 GETFIELD0 
+    1959 PUSHACC3 
+    1960 GETFIELD0 
+    1961 MAKEBLOCK2 0
+    1963 MAKEBLOCK2 0
+    1965 RETURN 3
+    1967 GETGLOBAL <0>(0, 0)
+    1969 RETURN 1
+    1971 RESTART 
+    1972 GRAB 1
+    1974 ACC0 
+    1975 BRANCHIFNOT 1996
+    1977 ACC1 
+    1978 BRANCHIFNOT 2003
+    1980 ACC1 
+    1981 GETFIELD1 
+    1982 PUSHACC1 
+    1983 GETFIELD1 
+    1984 PUSHOFFSETCLOSURE0 
+    1985 APPLY2 
+    1986 PUSHACC2 
+    1987 GETFIELD0 
+    1988 PUSHACC2 
+    1989 GETFIELD0 
+    1990 MAKEBLOCK2 0
+    1992 MAKEBLOCK2 0
+    1994 RETURN 2
+    1996 ACC1 
+    1997 BRANCHIFNOT 2001
+    1999 BRANCH 2003
+    2001 RETURN 2
+    2003 GETGLOBAL "List.combine"
+    2005 PUSHGETGLOBALFIELD Pervasives, 2
+    2008 APPTERM1 3
+    2010 RESTART 
+    2011 GRAB 1
+    2013 ACC1 
+    2014 BRANCHIFNOT 2038
+    2016 ACC1 
+    2017 GETFIELD0 
+    2018 PUSHACC2 
+    2019 GETFIELD1 
+    2020 PUSHACC1 
+    2021 PUSHENVACC2 
+    2022 APPLY1 
+    2023 BRANCHIFNOT 2033
+    2025 ACC0 
+    2026 PUSHACC3 
+    2027 PUSHACC3 
+    2028 MAKEBLOCK2 0
+    2030 PUSHOFFSETCLOSURE0 
+    2031 APPTERM2 6
+    2033 ACC0 
+    2034 PUSHACC3 
+    2035 PUSHOFFSETCLOSURE0 
+    2036 APPTERM2 6
+    2038 ACC0 
+    2039 PUSHENVACC1 
+    2040 APPTERM1 3
+    2042 ACC0 
+    2043 PUSHENVACC1 
+    2044 CLOSUREREC 2, 2011
+    2048 CONST0 
+    2049 PUSHACC1 
+    2050 APPTERM1 3
+    2052 RESTART 
+    2053 GRAB 2
+    2055 ACC1 
+    2056 BRANCHIFNOT 2077
+    2058 ACC2 
+    2059 BRANCHIFNOT 2084
+    2061 ACC2 
+    2062 GETFIELD1 
+    2063 PUSHACC2 
+    2064 GETFIELD1 
+    2065 PUSHACC2 
+    2066 PUSHACC5 
+    2067 GETFIELD0 
+    2068 PUSHACC5 
+    2069 GETFIELD0 
+    2070 PUSHENVACC1 
+    2071 APPLY2 
+    2072 MAKEBLOCK2 0
+    2074 PUSHOFFSETCLOSURE0 
+    2075 APPTERM3 6
+    2077 ACC2 
+    2078 BRANCHIFNOT 2082
+    2080 BRANCH 2084
+    2082 RETURN 3
+    2084 GETGLOBAL "List.rev_map2"
+    2086 PUSHGETGLOBALFIELD Pervasives, 2
+    2089 APPTERM1 4
+    2091 RESTART 
+    2092 GRAB 2
+    2094 ACC0 
+    2095 CLOSUREREC 1, 2053
+    2099 ACC3 
+    2100 PUSHACC3 
+    2101 PUSHCONST0 
+    2102 PUSHACC3 
+    2103 APPTERM3 7
+    2105 RESTART 
+    2106 GRAB 1
+    2108 ACC1 
+    2109 BRANCHIFNOT 2123
+    2111 ACC1 
+    2112 GETFIELD1 
+    2113 PUSHACC1 
+    2114 PUSHACC3 
+    2115 GETFIELD0 
+    2116 PUSHENVACC1 
+    2117 APPLY1 
+    2118 MAKEBLOCK2 0
+    2120 PUSHOFFSETCLOSURE0 
+    2121 APPTERM2 4
+    2123 ACC0 
+    2124 RETURN 2
+    2126 RESTART 
+    2127 GRAB 1
+    2129 ACC0 
+    2130 CLOSUREREC 1, 2106
+    2134 ACC2 
+    2135 PUSHCONST0 
+    2136 PUSHACC2 
+    2137 APPTERM2 5
+    2139 CONST0 
+    2140 PUSHACC1 
+    2141 PUSHENVACC1 
+    2142 APPTERM2 3
+    2144 ACC0 
+    2145 BRANCHIFNOT 2151
+    2147 ACC0 
+    2148 GETFIELD1 
+    2149 RETURN 1
+    2151 GETGLOBAL "tl"
+    2153 PUSHGETGLOBALFIELD Pervasives, 3
+    2156 APPTERM1 2
+    2158 ACC0 
+    2159 BRANCHIFNOT 2165
+    2161 ACC0 
+    2162 GETFIELD0 
+    2163 RETURN 1
+    2165 GETGLOBAL "hd"
+    2167 PUSHGETGLOBALFIELD Pervasives, 3
+    2170 APPTERM1 2
+    2172 ACC0 
+    2173 PUSHCONST0 
+    2174 PUSHENVACC1 
+    2175 APPTERM2 3
+    2177 CLOSUREREC 0, 1200
+    2181 ACC0 
+    2182 CLOSURE 1, 2172
+    2185 PUSH 
+    2186 CLOSURE 0, 2158
+    2189 PUSH 
+    2190 CLOSURE 0, 2144
+    2193 PUSH 
+    2194 CLOSUREREC 0, 1217
+    2198 GETGLOBALFIELD Pervasives, 16
+    2201 PUSH 
+    2202 CLOSUREREC 0, 1259
+    2206 ACC0 
+    2207 CLOSURE 1, 2139
+    2210 PUSH 
+    2211 CLOSUREREC 0, 1277
+    2215 CLOSUREREC 0, 1294
+    2219 CLOSURE 0, 2127
+    2222 PUSH 
+    2223 CLOSUREREC 0, 1316
+    2227 CLOSUREREC 0, 1334
+    2231 CLOSUREREC 0, 1354
+    2235 CLOSUREREC 0, 1374
+    2239 CLOSURE 0, 2092
+    2242 PUSH 
+    2243 CLOSUREREC 0, 1415
+    2247 CLOSUREREC 0, 1452
+    2251 CLOSUREREC 0, 1490
+    2255 CLOSUREREC 0, 1530
+    2259 CLOSUREREC 0, 1553
+    2263 CLOSUREREC 0, 1573
+    2267 CLOSUREREC 0, 1613
+    2271 CLOSUREREC 0, 1654
+    2275 CLOSUREREC 0, 1675
+    2279 CLOSUREREC 0, 1695
+    2283 CLOSUREREC 0, 1725
+    2287 CLOSUREREC 0, 1754
+    2291 CLOSUREREC 0, 1776
+    2295 CLOSUREREC 0, 1797
+    2299 CLOSUREREC 0, 1828
+    2303 CLOSUREREC 0, 1858
+    2307 ACC 24
+    2309 CLOSURE 1, 2042
+    2312 PUSHACC 25
+    2314 CLOSUREREC 1, 1928
+    2318 CLOSUREREC 0, 1942
+    2322 CLOSUREREC 0, 1972
+    2326 ACC0 
+    2327 PUSHACC2 
+    2328 PUSHACC7 
+    2329 PUSHACC 9
+    2331 PUSHACC 11
+    2333 PUSHACC 13
+    2335 PUSHACC 15
+    2337 PUSHACC 17
+    2339 PUSHACC 10
+    2341 PUSHACC 12
+    2343 PUSHACC 13
+    2345 PUSHACC 15
+    2347 PUSHACC 23
+    2349 PUSHACC 25
+    2351 PUSHACC 27
+    2353 PUSHACC 29
+    2355 PUSHACC 31
+    2357 PUSHACC 33
+    2359 PUSHACC 35
+    2361 PUSHACC 37
+    2363 PUSHACC 40
+    2365 PUSHACC 42
+    2367 PUSHACC 41
+    2369 PUSHACC 45
+    2371 PUSHACC 47
+    2373 PUSHACC 50
+    2375 PUSHACC 52
+    2377 PUSHACC 51
+    2379 PUSHACC 55
+    2381 PUSHACC 56
+    2383 PUSHACC 59
+    2385 PUSHACC 61
+    2387 PUSHACC 60
+    2389 PUSHACC 64
+    2391 PUSHACC 66
+    2393 PUSHACC 68
+    2395 PUSHACC 70
+    2397 MAKEBLOCK 37, 0
+    2400 POP 36
+    2402 SETGLOBAL List
+    2404 BRANCH 2432
+    2406 CONST0 
+    2407 PUSHACC1 
+    2408 LEINT 
+    2409 BRANCHIFNOT 2414
+    2411 CONST0 
+    2412 RETURN 1
+    2414 ACC0 
+    2415 OFFSETINT -1
+    2417 PUSHOFFSETCLOSURE0 
+    2418 APPLY1 
+    2419 PUSHACC1 
+    2420 MAKEBLOCK2 0
+    2422 RETURN 1
+    2424 RESTART 
+    2425 GRAB 1
+    2427 ACC1 
+    2428 PUSHACC1 
+    2429 ADDINT 
+    2430 RETURN 2
+    2432 CLOSUREREC 0, 2406
+    2436 CONSTINT 300
+    2438 PUSHACC1 
+    2439 APPLY1 
+    2440 PUSHCONST0 
+    2441 C_CALL1 gc_major
+    2443 CONSTINT 150
+    2445 PUSHCONSTINT 301
+    2447 MULINT 
+    2448 PUSHACC1 
+    2449 PUSHCONST0 
+    2450 PUSH 
+    2451 CLOSURE 0, 2425
+    2454 PUSHGETGLOBALFIELD List, 12
+    2457 APPLY3 
+    2458 NEQ 
+    2459 BRANCHIFNOT 2466
+    2461 GETGLOBAL Not_found
+    2463 MAKEBLOCK1 0
+    2465 RAISE 
+    2466 POP 2
+    2468 ATOM0 
+    2469 SETGLOBAL T320-gc-2
+    2471 STOP 
+**)
diff --git a/test/testinterp/t320-gc-3.ml b/test/testinterp/t320-gc-3.ml
new file mode 100644
index 00000000..7c33d2fd
--- /dev/null
+++ b/test/testinterp/t320-gc-3.ml
@@ -0,0 +1,1589 @@
+open Lib;;
+let rec f n =
+  if n <= 0 then []
+  else n :: f (n-1)
+in
+let l = f 300 in
+Gc.full_major ();
+if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 BRANCH 2177
+    1199 RESTART 
+    1200 GRAB 1
+    1202 ACC1 
+    1203 BRANCHIFNOT 1213
+    1205 ACC1 
+    1206 GETFIELD1 
+    1207 PUSHACC1 
+    1208 OFFSETINT 1
+    1210 PUSHOFFSETCLOSURE0 
+    1211 APPTERM2 4
+    1213 ACC0 
+    1214 RETURN 2
+    1216 RESTART 
+    1217 GRAB 1
+    1219 ACC0 
+    1220 BRANCHIFNOT 1251
+    1222 CONST0 
+    1223 PUSHACC2 
+    1224 EQ 
+    1225 BRANCHIFNOT 1231
+    1227 ACC0 
+    1228 GETFIELD0 
+    1229 RETURN 2
+    1231 CONST0 
+    1232 PUSHACC2 
+    1233 GTINT 
+    1234 BRANCHIFNOT 1244
+    1236 ACC1 
+    1237 OFFSETINT -1
+    1239 PUSHACC1 
+    1240 GETFIELD1 
+    1241 PUSHOFFSETCLOSURE0 
+    1242 APPTERM2 4
+    1244 GETGLOBAL "List.nth"
+    1246 PUSHGETGLOBALFIELD Pervasives, 2
+    1249 APPTERM1 3
+    1251 GETGLOBAL "nth"
+    1253 PUSHGETGLOBALFIELD Pervasives, 3
+    1256 APPTERM1 3
+    1258 RESTART 
+    1259 GRAB 1
+    1261 ACC0 
+    1262 BRANCHIFNOT 1274
+    1264 ACC1 
+    1265 PUSHACC1 
+    1266 GETFIELD0 
+    1267 MAKEBLOCK2 0
+    1269 PUSHACC1 
+    1270 GETFIELD1 
+    1271 PUSHOFFSETCLOSURE0 
+    1272 APPTERM2 4
+    1274 ACC1 
+    1275 RETURN 2
+    1277 ACC0 
+    1278 BRANCHIFNOT 1291
+    1280 ACC0 
+    1281 GETFIELD1 
+    1282 PUSHOFFSETCLOSURE0 
+    1283 APPLY1 
+    1284 PUSHACC1 
+    1285 GETFIELD0 
+    1286 PUSHGETGLOBALFIELD Pervasives, 16
+    1289 APPTERM2 3
+    1291 RETURN 1
+    1293 RESTART 
+    1294 GRAB 1
+    1296 ACC1 
+    1297 BRANCHIFNOT 1313
+    1299 ACC1 
+    1300 GETFIELD0 
+    1301 PUSHACC1 
+    1302 APPLY1 
+    1303 PUSHACC2 
+    1304 GETFIELD1 
+    1305 PUSHACC2 
+    1306 PUSHOFFSETCLOSURE0 
+    1307 APPLY2 
+    1308 PUSHACC1 
+    1309 MAKEBLOCK2 0
+    1311 POP 1
+    1313 RETURN 2
+    1315 RESTART 
+    1316 GRAB 1
+    1318 ACC1 
+    1319 BRANCHIFNOT 1331
+    1321 ACC1 
+    1322 GETFIELD0 
+    1323 PUSHACC1 
+    1324 APPLY1 
+    1325 ACC1 
+    1326 GETFIELD1 
+    1327 PUSHACC1 
+    1328 PUSHOFFSETCLOSURE0 
+    1329 APPTERM2 4
+    1331 RETURN 2
+    1333 RESTART 
+    1334 GRAB 2
+    1336 ACC2 
+    1337 BRANCHIFNOT 1350
+    1339 ACC2 
+    1340 GETFIELD1 
+    1341 PUSHACC3 
+    1342 GETFIELD0 
+    1343 PUSHACC3 
+    1344 PUSHACC3 
+    1345 APPLY2 
+    1346 PUSHACC2 
+    1347 PUSHOFFSETCLOSURE0 
+    1348 APPTERM3 6
+    1350 ACC1 
+    1351 RETURN 3
+    1353 RESTART 
+    1354 GRAB 2
+    1356 ACC1 
+    1357 BRANCHIFNOT 1370
+    1359 ACC2 
+    1360 PUSHACC2 
+    1361 GETFIELD1 
+    1362 PUSHACC2 
+    1363 PUSHOFFSETCLOSURE0 
+    1364 APPLY3 
+    1365 PUSHACC2 
+    1366 GETFIELD0 
+    1367 PUSHACC2 
+    1368 APPTERM2 5
+    1370 ACC2 
+    1371 RETURN 3
+    1373 RESTART 
+    1374 GRAB 2
+    1376 ACC1 
+    1377 BRANCHIFNOT 1400
+    1379 ACC2 
+    1380 BRANCHIFNOT 1407
+    1382 ACC2 
+    1383 GETFIELD0 
+    1384 PUSHACC2 
+    1385 GETFIELD0 
+    1386 PUSHACC2 
+    1387 APPLY2 
+    1388 PUSHACC3 
+    1389 GETFIELD1 
+    1390 PUSHACC3 
+    1391 GETFIELD1 
+    1392 PUSHACC3 
+    1393 PUSHOFFSETCLOSURE0 
+    1394 APPLY3 
+    1395 PUSHACC1 
+    1396 MAKEBLOCK2 0
+    1398 RETURN 4
+    1400 ACC2 
+    1401 BRANCHIFNOT 1405
+    1403 BRANCH 1407
+    1405 RETURN 3
+    1407 GETGLOBAL "List.map2"
+    1409 PUSHGETGLOBALFIELD Pervasives, 2
+    1412 APPTERM1 4
+    1414 RESTART 
+    1415 GRAB 2
+    1417 ACC1 
+    1418 BRANCHIFNOT 1437
+    1420 ACC2 
+    1421 BRANCHIFNOT 1444
+    1423 ACC2 
+    1424 GETFIELD0 
+    1425 PUSHACC2 
+    1426 GETFIELD0 
+    1427 PUSHACC2 
+    1428 APPLY2 
+    1429 ACC2 
+    1430 GETFIELD1 
+    1431 PUSHACC2 
+    1432 GETFIELD1 
+    1433 PUSHACC2 
+    1434 PUSHOFFSETCLOSURE0 
+    1435 APPTERM3 6
+    1437 ACC2 
+    1438 BRANCHIFNOT 1442
+    1440 BRANCH 1444
+    1442 RETURN 3
+    1444 GETGLOBAL "List.iter2"
+    1446 PUSHGETGLOBALFIELD Pervasives, 2
+    1449 APPTERM1 4
+    1451 RESTART 
+    1452 GRAB 3
+    1454 ACC2 
+    1455 BRANCHIFNOT 1476
+    1457 ACC3 
+    1458 BRANCHIFNOT 1482
+    1460 ACC3 
+    1461 GETFIELD1 
+    1462 PUSHACC3 
+    1463 GETFIELD1 
+    1464 PUSHACC5 
+    1465 GETFIELD0 
+    1466 PUSHACC5 
+    1467 GETFIELD0 
+    1468 PUSHACC5 
+    1469 PUSHACC5 
+    1470 APPLY3 
+    1471 PUSHACC3 
+    1472 PUSHOFFSETCLOSURE0 
+    1473 APPTERM 4, 8
+    1476 ACC3 
+    1477 BRANCHIF 1482
+    1479 ACC1 
+    1480 RETURN 4
+    1482 GETGLOBAL "List.fold_left2"
+    1484 PUSHGETGLOBALFIELD Pervasives, 2
+    1487 APPTERM1 5
+    1489 RESTART 
+    1490 GRAB 3
+    1492 ACC1 
+    1493 BRANCHIFNOT 1516
+    1495 ACC2 
+    1496 BRANCHIFNOT 1522
+    1498 PUSH_RETADDR 1509
+    1500 ACC6 
+    1501 PUSHACC6 
+    1502 GETFIELD1 
+    1503 PUSHACC6 
+    1504 GETFIELD1 
+    1505 PUSHACC6 
+    1506 PUSHOFFSETCLOSURE0 
+    1507 APPLY 4
+    1509 PUSHACC3 
+    1510 GETFIELD0 
+    1511 PUSHACC3 
+    1512 GETFIELD0 
+    1513 PUSHACC3 
+    1514 APPTERM3 7
+    1516 ACC2 
+    1517 BRANCHIF 1522
+    1519 ACC3 
+    1520 RETURN 4
+    1522 GETGLOBAL "List.fold_right2"
+    1524 PUSHGETGLOBALFIELD Pervasives, 2
+    1527 APPTERM1 5
+    1529 RESTART 
+    1530 GRAB 1
+    1532 ACC1 
+    1533 BRANCHIFNOT 1549
+    1535 ACC1 
+    1536 GETFIELD0 
+    1537 PUSHACC1 
+    1538 APPLY1 
+    1539 BRANCHIFNOT 1547
+    1541 ACC1 
+    1542 GETFIELD1 
+    1543 PUSHACC1 
+    1544 PUSHOFFSETCLOSURE0 
+    1545 APPTERM2 4
+    1547 RETURN 2
+    1549 CONST1 
+    1550 RETURN 2
+    1552 RESTART 
+    1553 GRAB 1
+    1555 ACC1 
+    1556 BRANCHIFNOT 1570
+    1558 ACC1 
+    1559 GETFIELD0 
+    1560 PUSHACC1 
+    1561 APPLY1 
+    1562 BRANCHIF 1570
+    1564 ACC1 
+    1565 GETFIELD1 
+    1566 PUSHACC1 
+    1567 PUSHOFFSETCLOSURE0 
+    1568 APPTERM2 4
+    1570 RETURN 2
+    1572 RESTART 
+    1573 GRAB 2
+    1575 ACC1 
+    1576 BRANCHIFNOT 1599
+    1578 ACC2 
+    1579 BRANCHIFNOT 1605
+    1581 ACC2 
+    1582 GETFIELD0 
+    1583 PUSHACC2 
+    1584 GETFIELD0 
+    1585 PUSHACC2 
+    1586 APPLY2 
+    1587 BRANCHIFNOT 1597
+    1589 ACC2 
+    1590 GETFIELD1 
+    1591 PUSHACC2 
+    1592 GETFIELD1 
+    1593 PUSHACC2 
+    1594 PUSHOFFSETCLOSURE0 
+    1595 APPTERM3 6
+    1597 RETURN 3
+    1599 ACC2 
+    1600 BRANCHIF 1605
+    1602 CONST1 
+    1603 RETURN 3
+    1605 GETGLOBAL "List.for_all2"
+    1607 PUSHGETGLOBALFIELD Pervasives, 2
+    1610 APPTERM1 4
+    1612 RESTART 
+    1613 GRAB 2
+    1615 ACC1 
+    1616 BRANCHIFNOT 1639
+    1618 ACC2 
+    1619 BRANCHIFNOT 1646
+    1621 ACC2 
+    1622 GETFIELD0 
+    1623 PUSHACC2 
+    1624 GETFIELD0 
+    1625 PUSHACC2 
+    1626 APPLY2 
+    1627 BRANCHIF 1637
+    1629 ACC2 
+    1630 GETFIELD1 
+    1631 PUSHACC2 
+    1632 GETFIELD1 
+    1633 PUSHACC2 
+    1634 PUSHOFFSETCLOSURE0 
+    1635 APPTERM3 6
+    1637 RETURN 3
+    1639 ACC2 
+    1640 BRANCHIFNOT 1644
+    1642 BRANCH 1646
+    1644 RETURN 3
+    1646 GETGLOBAL "List.exists2"
+    1648 PUSHGETGLOBALFIELD Pervasives, 2
+    1651 APPTERM1 4
+    1653 RESTART 
+    1654 GRAB 1
+    1656 ACC1 
+    1657 BRANCHIFNOT 1672
+    1659 ACC0 
+    1660 PUSHACC2 
+    1661 GETFIELD0 
+    1662 C_CALL2 equal
+    1664 BRANCHIF 1672
+    1666 ACC1 
+    1667 GETFIELD1 
+    1668 PUSHACC1 
+    1669 PUSHOFFSETCLOSURE0 
+    1670 APPTERM2 4
+    1672 RETURN 2
+    1674 RESTART 
+    1675 GRAB 1
+    1677 ACC1 
+    1678 BRANCHIFNOT 1692
+    1680 ACC0 
+    1681 PUSHACC2 
+    1682 GETFIELD0 
+    1683 EQ 
+    1684 BRANCHIF 1692
+    1686 ACC1 
+    1687 GETFIELD1 
+    1688 PUSHACC1 
+    1689 PUSHOFFSETCLOSURE0 
+    1690 APPTERM2 4
+    1692 RETURN 2
+    1694 RESTART 
+    1695 GRAB 1
+    1697 ACC1 
+    1698 BRANCHIFNOT 1719
+    1700 ACC1 
+    1701 GETFIELD0 
+    1702 PUSHACC1 
+    1703 PUSHACC1 
+    1704 GETFIELD0 
+    1705 C_CALL2 equal
+    1707 BRANCHIFNOT 1713
+    1709 ACC0 
+    1710 GETFIELD1 
+    1711 RETURN 3
+    1713 ACC2 
+    1714 GETFIELD1 
+    1715 PUSHACC2 
+    1716 PUSHOFFSETCLOSURE0 
+    1717 APPTERM2 5
+    1719 GETGLOBAL Not_found
+    1721 MAKEBLOCK1 0
+    1723 RAISE 
+    1724 RESTART 
+    1725 GRAB 1
+    1727 ACC1 
+    1728 BRANCHIFNOT 1748
+    1730 ACC1 
+    1731 GETFIELD0 
+    1732 PUSHACC1 
+    1733 PUSHACC1 
+    1734 GETFIELD0 
+    1735 EQ 
+    1736 BRANCHIFNOT 1742
+    1738 ACC0 
+    1739 GETFIELD1 
+    1740 RETURN 3
+    1742 ACC2 
+    1743 GETFIELD1 
+    1744 PUSHACC2 
+    1745 PUSHOFFSETCLOSURE0 
+    1746 APPTERM2 5
+    1748 GETGLOBAL Not_found
+    1750 MAKEBLOCK1 0
+    1752 RAISE 
+    1753 RESTART 
+    1754 GRAB 1
+    1756 ACC1 
+    1757 BRANCHIFNOT 1773
+    1759 ACC0 
+    1760 PUSHACC2 
+    1761 GETFIELD0 
+    1762 GETFIELD0 
+    1763 C_CALL2 equal
+    1765 BRANCHIF 1773
+    1767 ACC1 
+    1768 GETFIELD1 
+    1769 PUSHACC1 
+    1770 PUSHOFFSETCLOSURE0 
+    1771 APPTERM2 4
+    1773 RETURN 2
+    1775 RESTART 
+    1776 GRAB 1
+    1778 ACC1 
+    1779 BRANCHIFNOT 1794
+    1781 ACC0 
+    1782 PUSHACC2 
+    1783 GETFIELD0 
+    1784 GETFIELD0 
+    1785 EQ 
+    1786 BRANCHIF 1794
+    1788 ACC1 
+    1789 GETFIELD1 
+    1790 PUSHACC1 
+    1791 PUSHOFFSETCLOSURE0 
+    1792 APPTERM2 4
+    1794 RETURN 2
+    1796 RESTART 
+    1797 GRAB 1
+    1799 ACC1 
+    1800 BRANCHIFNOT 1825
+    1802 ACC1 
+    1803 GETFIELD0 
+    1804 PUSHACC2 
+    1805 GETFIELD1 
+    1806 PUSHACC2 
+    1807 PUSHACC2 
+    1808 GETFIELD0 
+    1809 C_CALL2 equal
+    1811 BRANCHIFNOT 1816
+    1813 ACC0 
+    1814 RETURN 4
+    1816 ACC0 
+    1817 PUSHACC3 
+    1818 PUSHOFFSETCLOSURE0 
+    1819 APPLY2 
+    1820 PUSHACC2 
+    1821 MAKEBLOCK2 0
+    1823 POP 2
+    1825 RETURN 2
+    1827 RESTART 
+    1828 GRAB 1
+    1830 ACC1 
+    1831 BRANCHIFNOT 1855
+    1833 ACC1 
+    1834 GETFIELD0 
+    1835 PUSHACC2 
+    1836 GETFIELD1 
+    1837 PUSHACC2 
+    1838 PUSHACC2 
+    1839 GETFIELD0 
+    1840 EQ 
+    1841 BRANCHIFNOT 1846
+    1843 ACC0 
+    1844 RETURN 4
+    1846 ACC0 
+    1847 PUSHACC3 
+    1848 PUSHOFFSETCLOSURE0 
+    1849 APPLY2 
+    1850 PUSHACC2 
+    1851 MAKEBLOCK2 0
+    1853 POP 2
+    1855 RETURN 2
+    1857 RESTART 
+    1858 GRAB 1
+    1860 ACC1 
+    1861 BRANCHIFNOT 1879
+    1863 ACC1 
+    1864 GETFIELD0 
+    1865 PUSHACC0 
+    1866 PUSHACC2 
+    1867 APPLY1 
+    1868 BRANCHIFNOT 1873
+    1870 ACC0 
+    1871 RETURN 3
+    1873 ACC2 
+    1874 GETFIELD1 
+    1875 PUSHACC2 
+    1876 PUSHOFFSETCLOSURE0 
+    1877 APPTERM2 5
+    1879 GETGLOBAL Not_found
+    1881 MAKEBLOCK1 0
+    1883 RAISE 
+    1884 RESTART 
+    1885 GRAB 2
+    1887 ACC2 
+    1888 BRANCHIFNOT 1917
+    1890 ACC2 
+    1891 GETFIELD0 
+    1892 PUSHACC3 
+    1893 GETFIELD1 
+    1894 PUSHACC1 
+    1895 PUSHENVACC2 
+    1896 APPLY1 
+    1897 BRANCHIFNOT 1908
+    1899 ACC0 
+    1900 PUSHACC4 
+    1901 PUSHACC4 
+    1902 PUSHACC4 
+    1903 MAKEBLOCK2 0
+    1905 PUSHOFFSETCLOSURE0 
+    1906 APPTERM3 8
+    1908 ACC0 
+    1909 PUSHACC4 
+    1910 PUSHACC3 
+    1911 MAKEBLOCK2 0
+    1913 PUSHACC4 
+    1914 PUSHOFFSETCLOSURE0 
+    1915 APPTERM3 8
+    1917 ACC1 
+    1918 PUSHENVACC1 
+    1919 APPLY1 
+    1920 PUSHACC1 
+    1921 PUSHENVACC1 
+    1922 APPLY1 
+    1923 MAKEBLOCK2 0
+    1925 RETURN 3
+    1927 RESTART 
+    1928 GRAB 1
+    1930 ACC0 
+    1931 PUSHENVACC1 
+    1932 CLOSUREREC 2, 1885
+    1936 ACC2 
+    1937 PUSHCONST0 
+    1938 PUSHCONST0 
+    1939 PUSHACC3 
+    1940 APPTERM3 6
+    1942 ACC0 
+    1943 BRANCHIFNOT 1967
+    1945 ACC0 
+    1946 GETFIELD0 
+    1947 PUSHACC1 
+    1948 GETFIELD1 
+    1949 PUSHOFFSETCLOSURE0 
+    1950 APPLY1 
+    1951 PUSHACC0 
+    1952 GETFIELD1 
+    1953 PUSHACC2 
+    1954 GETFIELD1 
+    1955 MAKEBLOCK2 0
+    1957 PUSHACC1 
+    1958 GETFIELD0 
+    1959 PUSHACC3 
+    1960 GETFIELD0 
+    1961 MAKEBLOCK2 0
+    1963 MAKEBLOCK2 0
+    1965 RETURN 3
+    1967 GETGLOBAL <0>(0, 0)
+    1969 RETURN 1
+    1971 RESTART 
+    1972 GRAB 1
+    1974 ACC0 
+    1975 BRANCHIFNOT 1996
+    1977 ACC1 
+    1978 BRANCHIFNOT 2003
+    1980 ACC1 
+    1981 GETFIELD1 
+    1982 PUSHACC1 
+    1983 GETFIELD1 
+    1984 PUSHOFFSETCLOSURE0 
+    1985 APPLY2 
+    1986 PUSHACC2 
+    1987 GETFIELD0 
+    1988 PUSHACC2 
+    1989 GETFIELD0 
+    1990 MAKEBLOCK2 0
+    1992 MAKEBLOCK2 0
+    1994 RETURN 2
+    1996 ACC1 
+    1997 BRANCHIFNOT 2001
+    1999 BRANCH 2003
+    2001 RETURN 2
+    2003 GETGLOBAL "List.combine"
+    2005 PUSHGETGLOBALFIELD Pervasives, 2
+    2008 APPTERM1 3
+    2010 RESTART 
+    2011 GRAB 1
+    2013 ACC1 
+    2014 BRANCHIFNOT 2038
+    2016 ACC1 
+    2017 GETFIELD0 
+    2018 PUSHACC2 
+    2019 GETFIELD1 
+    2020 PUSHACC1 
+    2021 PUSHENVACC2 
+    2022 APPLY1 
+    2023 BRANCHIFNOT 2033
+    2025 ACC0 
+    2026 PUSHACC3 
+    2027 PUSHACC3 
+    2028 MAKEBLOCK2 0
+    2030 PUSHOFFSETCLOSURE0 
+    2031 APPTERM2 6
+    2033 ACC0 
+    2034 PUSHACC3 
+    2035 PUSHOFFSETCLOSURE0 
+    2036 APPTERM2 6
+    2038 ACC0 
+    2039 PUSHENVACC1 
+    2040 APPTERM1 3
+    2042 ACC0 
+    2043 PUSHENVACC1 
+    2044 CLOSUREREC 2, 2011
+    2048 CONST0 
+    2049 PUSHACC1 
+    2050 APPTERM1 3
+    2052 RESTART 
+    2053 GRAB 2
+    2055 ACC1 
+    2056 BRANCHIFNOT 2077
+    2058 ACC2 
+    2059 BRANCHIFNOT 2084
+    2061 ACC2 
+    2062 GETFIELD1 
+    2063 PUSHACC2 
+    2064 GETFIELD1 
+    2065 PUSHACC2 
+    2066 PUSHACC5 
+    2067 GETFIELD0 
+    2068 PUSHACC5 
+    2069 GETFIELD0 
+    2070 PUSHENVACC1 
+    2071 APPLY2 
+    2072 MAKEBLOCK2 0
+    2074 PUSHOFFSETCLOSURE0 
+    2075 APPTERM3 6
+    2077 ACC2 
+    2078 BRANCHIFNOT 2082
+    2080 BRANCH 2084
+    2082 RETURN 3
+    2084 GETGLOBAL "List.rev_map2"
+    2086 PUSHGETGLOBALFIELD Pervasives, 2
+    2089 APPTERM1 4
+    2091 RESTART 
+    2092 GRAB 2
+    2094 ACC0 
+    2095 CLOSUREREC 1, 2053
+    2099 ACC3 
+    2100 PUSHACC3 
+    2101 PUSHCONST0 
+    2102 PUSHACC3 
+    2103 APPTERM3 7
+    2105 RESTART 
+    2106 GRAB 1
+    2108 ACC1 
+    2109 BRANCHIFNOT 2123
+    2111 ACC1 
+    2112 GETFIELD1 
+    2113 PUSHACC1 
+    2114 PUSHACC3 
+    2115 GETFIELD0 
+    2116 PUSHENVACC1 
+    2117 APPLY1 
+    2118 MAKEBLOCK2 0
+    2120 PUSHOFFSETCLOSURE0 
+    2121 APPTERM2 4
+    2123 ACC0 
+    2124 RETURN 2
+    2126 RESTART 
+    2127 GRAB 1
+    2129 ACC0 
+    2130 CLOSUREREC 1, 2106
+    2134 ACC2 
+    2135 PUSHCONST0 
+    2136 PUSHACC2 
+    2137 APPTERM2 5
+    2139 CONST0 
+    2140 PUSHACC1 
+    2141 PUSHENVACC1 
+    2142 APPTERM2 3
+    2144 ACC0 
+    2145 BRANCHIFNOT 2151
+    2147 ACC0 
+    2148 GETFIELD1 
+    2149 RETURN 1
+    2151 GETGLOBAL "tl"
+    2153 PUSHGETGLOBALFIELD Pervasives, 3
+    2156 APPTERM1 2
+    2158 ACC0 
+    2159 BRANCHIFNOT 2165
+    2161 ACC0 
+    2162 GETFIELD0 
+    2163 RETURN 1
+    2165 GETGLOBAL "hd"
+    2167 PUSHGETGLOBALFIELD Pervasives, 3
+    2170 APPTERM1 2
+    2172 ACC0 
+    2173 PUSHCONST0 
+    2174 PUSHENVACC1 
+    2175 APPTERM2 3
+    2177 CLOSUREREC 0, 1200
+    2181 ACC0 
+    2182 CLOSURE 1, 2172
+    2185 PUSH 
+    2186 CLOSURE 0, 2158
+    2189 PUSH 
+    2190 CLOSURE 0, 2144
+    2193 PUSH 
+    2194 CLOSUREREC 0, 1217
+    2198 GETGLOBALFIELD Pervasives, 16
+    2201 PUSH 
+    2202 CLOSUREREC 0, 1259
+    2206 ACC0 
+    2207 CLOSURE 1, 2139
+    2210 PUSH 
+    2211 CLOSUREREC 0, 1277
+    2215 CLOSUREREC 0, 1294
+    2219 CLOSURE 0, 2127
+    2222 PUSH 
+    2223 CLOSUREREC 0, 1316
+    2227 CLOSUREREC 0, 1334
+    2231 CLOSUREREC 0, 1354
+    2235 CLOSUREREC 0, 1374
+    2239 CLOSURE 0, 2092
+    2242 PUSH 
+    2243 CLOSUREREC 0, 1415
+    2247 CLOSUREREC 0, 1452
+    2251 CLOSUREREC 0, 1490
+    2255 CLOSUREREC 0, 1530
+    2259 CLOSUREREC 0, 1553
+    2263 CLOSUREREC 0, 1573
+    2267 CLOSUREREC 0, 1613
+    2271 CLOSUREREC 0, 1654
+    2275 CLOSUREREC 0, 1675
+    2279 CLOSUREREC 0, 1695
+    2283 CLOSUREREC 0, 1725
+    2287 CLOSUREREC 0, 1754
+    2291 CLOSUREREC 0, 1776
+    2295 CLOSUREREC 0, 1797
+    2299 CLOSUREREC 0, 1828
+    2303 CLOSUREREC 0, 1858
+    2307 ACC 24
+    2309 CLOSURE 1, 2042
+    2312 PUSHACC 25
+    2314 CLOSUREREC 1, 1928
+    2318 CLOSUREREC 0, 1942
+    2322 CLOSUREREC 0, 1972
+    2326 ACC0 
+    2327 PUSHACC2 
+    2328 PUSHACC7 
+    2329 PUSHACC 9
+    2331 PUSHACC 11
+    2333 PUSHACC 13
+    2335 PUSHACC 15
+    2337 PUSHACC 17
+    2339 PUSHACC 10
+    2341 PUSHACC 12
+    2343 PUSHACC 13
+    2345 PUSHACC 15
+    2347 PUSHACC 23
+    2349 PUSHACC 25
+    2351 PUSHACC 27
+    2353 PUSHACC 29
+    2355 PUSHACC 31
+    2357 PUSHACC 33
+    2359 PUSHACC 35
+    2361 PUSHACC 37
+    2363 PUSHACC 40
+    2365 PUSHACC 42
+    2367 PUSHACC 41
+    2369 PUSHACC 45
+    2371 PUSHACC 47
+    2373 PUSHACC 50
+    2375 PUSHACC 52
+    2377 PUSHACC 51
+    2379 PUSHACC 55
+    2381 PUSHACC 56
+    2383 PUSHACC 59
+    2385 PUSHACC 61
+    2387 PUSHACC 60
+    2389 PUSHACC 64
+    2391 PUSHACC 66
+    2393 PUSHACC 68
+    2395 PUSHACC 70
+    2397 MAKEBLOCK 37, 0
+    2400 POP 36
+    2402 SETGLOBAL List
+    2404 BRANCH 2432
+    2406 CONST0 
+    2407 PUSHACC1 
+    2408 LEINT 
+    2409 BRANCHIFNOT 2414
+    2411 CONST0 
+    2412 RETURN 1
+    2414 ACC0 
+    2415 OFFSETINT -1
+    2417 PUSHOFFSETCLOSURE0 
+    2418 APPLY1 
+    2419 PUSHACC1 
+    2420 MAKEBLOCK2 0
+    2422 RETURN 1
+    2424 RESTART 
+    2425 GRAB 1
+    2427 ACC1 
+    2428 PUSHACC1 
+    2429 ADDINT 
+    2430 RETURN 2
+    2432 CLOSUREREC 0, 2406
+    2436 CONSTINT 300
+    2438 PUSHACC1 
+    2439 APPLY1 
+    2440 PUSHCONST0 
+    2441 C_CALL1 gc_full_major
+    2443 CONSTINT 150
+    2445 PUSHCONSTINT 301
+    2447 MULINT 
+    2448 PUSHACC1 
+    2449 PUSHCONST0 
+    2450 PUSH 
+    2451 CLOSURE 0, 2425
+    2454 PUSHGETGLOBALFIELD List, 12
+    2457 APPLY3 
+    2458 NEQ 
+    2459 BRANCHIFNOT 2466
+    2461 GETGLOBAL Not_found
+    2463 MAKEBLOCK1 0
+    2465 RAISE 
+    2466 POP 2
+    2468 ATOM0 
+    2469 SETGLOBAL T320-gc-3
+    2471 STOP 
+**)
diff --git a/test/testinterp/t330-compact-1.ml b/test/testinterp/t330-compact-1.ml
new file mode 100644
index 00000000..efa958fd
--- /dev/null
+++ b/test/testinterp/t330-compact-1.ml
@@ -0,0 +1,15 @@
+open Lib;;
+Gc.compact ();;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 CONST0 
+      10 C_CALL1 gc_compaction
+      12 ATOM0 
+      13 SETGLOBAL T330-compact-1
+      15 STOP 
+**)
diff --git a/test/testinterp/t330-compact-2.ml b/test/testinterp/t330-compact-2.ml
new file mode 100644
index 00000000..62ab0141
--- /dev/null
+++ b/test/testinterp/t330-compact-2.ml
@@ -0,0 +1,755 @@
+open Lib;;
+Gc.compact ();;
+let _ = Pervasives.do_at_exit();;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 CONST0 
+    1198 C_CALL1 gc_compaction
+    1200 CONST0 
+    1201 PUSHGETGLOBALFIELD Pervasives, 68
+    1204 APPLY1 
+    1205 ATOM0 
+    1206 SETGLOBAL T330-compact-2
+    1208 STOP 
+**)
diff --git a/test/testinterp/t330-compact-3.ml b/test/testinterp/t330-compact-3.ml
new file mode 100644
index 00000000..f25c64ef
--- /dev/null
+++ b/test/testinterp/t330-compact-3.ml
@@ -0,0 +1,1589 @@
+open Lib;;
+let rec f n =
+  if n <= 0 then []
+  else n :: f (n-1)
+in
+let l = f 300 in
+Gc.compact ();
+if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 BRANCH 2177
+    1199 RESTART 
+    1200 GRAB 1
+    1202 ACC1 
+    1203 BRANCHIFNOT 1213
+    1205 ACC1 
+    1206 GETFIELD1 
+    1207 PUSHACC1 
+    1208 OFFSETINT 1
+    1210 PUSHOFFSETCLOSURE0 
+    1211 APPTERM2 4
+    1213 ACC0 
+    1214 RETURN 2
+    1216 RESTART 
+    1217 GRAB 1
+    1219 ACC0 
+    1220 BRANCHIFNOT 1251
+    1222 CONST0 
+    1223 PUSHACC2 
+    1224 EQ 
+    1225 BRANCHIFNOT 1231
+    1227 ACC0 
+    1228 GETFIELD0 
+    1229 RETURN 2
+    1231 CONST0 
+    1232 PUSHACC2 
+    1233 GTINT 
+    1234 BRANCHIFNOT 1244
+    1236 ACC1 
+    1237 OFFSETINT -1
+    1239 PUSHACC1 
+    1240 GETFIELD1 
+    1241 PUSHOFFSETCLOSURE0 
+    1242 APPTERM2 4
+    1244 GETGLOBAL "List.nth"
+    1246 PUSHGETGLOBALFIELD Pervasives, 2
+    1249 APPTERM1 3
+    1251 GETGLOBAL "nth"
+    1253 PUSHGETGLOBALFIELD Pervasives, 3
+    1256 APPTERM1 3
+    1258 RESTART 
+    1259 GRAB 1
+    1261 ACC0 
+    1262 BRANCHIFNOT 1274
+    1264 ACC1 
+    1265 PUSHACC1 
+    1266 GETFIELD0 
+    1267 MAKEBLOCK2 0
+    1269 PUSHACC1 
+    1270 GETFIELD1 
+    1271 PUSHOFFSETCLOSURE0 
+    1272 APPTERM2 4
+    1274 ACC1 
+    1275 RETURN 2
+    1277 ACC0 
+    1278 BRANCHIFNOT 1291
+    1280 ACC0 
+    1281 GETFIELD1 
+    1282 PUSHOFFSETCLOSURE0 
+    1283 APPLY1 
+    1284 PUSHACC1 
+    1285 GETFIELD0 
+    1286 PUSHGETGLOBALFIELD Pervasives, 16
+    1289 APPTERM2 3
+    1291 RETURN 1
+    1293 RESTART 
+    1294 GRAB 1
+    1296 ACC1 
+    1297 BRANCHIFNOT 1313
+    1299 ACC1 
+    1300 GETFIELD0 
+    1301 PUSHACC1 
+    1302 APPLY1 
+    1303 PUSHACC2 
+    1304 GETFIELD1 
+    1305 PUSHACC2 
+    1306 PUSHOFFSETCLOSURE0 
+    1307 APPLY2 
+    1308 PUSHACC1 
+    1309 MAKEBLOCK2 0
+    1311 POP 1
+    1313 RETURN 2
+    1315 RESTART 
+    1316 GRAB 1
+    1318 ACC1 
+    1319 BRANCHIFNOT 1331
+    1321 ACC1 
+    1322 GETFIELD0 
+    1323 PUSHACC1 
+    1324 APPLY1 
+    1325 ACC1 
+    1326 GETFIELD1 
+    1327 PUSHACC1 
+    1328 PUSHOFFSETCLOSURE0 
+    1329 APPTERM2 4
+    1331 RETURN 2
+    1333 RESTART 
+    1334 GRAB 2
+    1336 ACC2 
+    1337 BRANCHIFNOT 1350
+    1339 ACC2 
+    1340 GETFIELD1 
+    1341 PUSHACC3 
+    1342 GETFIELD0 
+    1343 PUSHACC3 
+    1344 PUSHACC3 
+    1345 APPLY2 
+    1346 PUSHACC2 
+    1347 PUSHOFFSETCLOSURE0 
+    1348 APPTERM3 6
+    1350 ACC1 
+    1351 RETURN 3
+    1353 RESTART 
+    1354 GRAB 2
+    1356 ACC1 
+    1357 BRANCHIFNOT 1370
+    1359 ACC2 
+    1360 PUSHACC2 
+    1361 GETFIELD1 
+    1362 PUSHACC2 
+    1363 PUSHOFFSETCLOSURE0 
+    1364 APPLY3 
+    1365 PUSHACC2 
+    1366 GETFIELD0 
+    1367 PUSHACC2 
+    1368 APPTERM2 5
+    1370 ACC2 
+    1371 RETURN 3
+    1373 RESTART 
+    1374 GRAB 2
+    1376 ACC1 
+    1377 BRANCHIFNOT 1400
+    1379 ACC2 
+    1380 BRANCHIFNOT 1407
+    1382 ACC2 
+    1383 GETFIELD0 
+    1384 PUSHACC2 
+    1385 GETFIELD0 
+    1386 PUSHACC2 
+    1387 APPLY2 
+    1388 PUSHACC3 
+    1389 GETFIELD1 
+    1390 PUSHACC3 
+    1391 GETFIELD1 
+    1392 PUSHACC3 
+    1393 PUSHOFFSETCLOSURE0 
+    1394 APPLY3 
+    1395 PUSHACC1 
+    1396 MAKEBLOCK2 0
+    1398 RETURN 4
+    1400 ACC2 
+    1401 BRANCHIFNOT 1405
+    1403 BRANCH 1407
+    1405 RETURN 3
+    1407 GETGLOBAL "List.map2"
+    1409 PUSHGETGLOBALFIELD Pervasives, 2
+    1412 APPTERM1 4
+    1414 RESTART 
+    1415 GRAB 2
+    1417 ACC1 
+    1418 BRANCHIFNOT 1437
+    1420 ACC2 
+    1421 BRANCHIFNOT 1444
+    1423 ACC2 
+    1424 GETFIELD0 
+    1425 PUSHACC2 
+    1426 GETFIELD0 
+    1427 PUSHACC2 
+    1428 APPLY2 
+    1429 ACC2 
+    1430 GETFIELD1 
+    1431 PUSHACC2 
+    1432 GETFIELD1 
+    1433 PUSHACC2 
+    1434 PUSHOFFSETCLOSURE0 
+    1435 APPTERM3 6
+    1437 ACC2 
+    1438 BRANCHIFNOT 1442
+    1440 BRANCH 1444
+    1442 RETURN 3
+    1444 GETGLOBAL "List.iter2"
+    1446 PUSHGETGLOBALFIELD Pervasives, 2
+    1449 APPTERM1 4
+    1451 RESTART 
+    1452 GRAB 3
+    1454 ACC2 
+    1455 BRANCHIFNOT 1476
+    1457 ACC3 
+    1458 BRANCHIFNOT 1482
+    1460 ACC3 
+    1461 GETFIELD1 
+    1462 PUSHACC3 
+    1463 GETFIELD1 
+    1464 PUSHACC5 
+    1465 GETFIELD0 
+    1466 PUSHACC5 
+    1467 GETFIELD0 
+    1468 PUSHACC5 
+    1469 PUSHACC5 
+    1470 APPLY3 
+    1471 PUSHACC3 
+    1472 PUSHOFFSETCLOSURE0 
+    1473 APPTERM 4, 8
+    1476 ACC3 
+    1477 BRANCHIF 1482
+    1479 ACC1 
+    1480 RETURN 4
+    1482 GETGLOBAL "List.fold_left2"
+    1484 PUSHGETGLOBALFIELD Pervasives, 2
+    1487 APPTERM1 5
+    1489 RESTART 
+    1490 GRAB 3
+    1492 ACC1 
+    1493 BRANCHIFNOT 1516
+    1495 ACC2 
+    1496 BRANCHIFNOT 1522
+    1498 PUSH_RETADDR 1509
+    1500 ACC6 
+    1501 PUSHACC6 
+    1502 GETFIELD1 
+    1503 PUSHACC6 
+    1504 GETFIELD1 
+    1505 PUSHACC6 
+    1506 PUSHOFFSETCLOSURE0 
+    1507 APPLY 4
+    1509 PUSHACC3 
+    1510 GETFIELD0 
+    1511 PUSHACC3 
+    1512 GETFIELD0 
+    1513 PUSHACC3 
+    1514 APPTERM3 7
+    1516 ACC2 
+    1517 BRANCHIF 1522
+    1519 ACC3 
+    1520 RETURN 4
+    1522 GETGLOBAL "List.fold_right2"
+    1524 PUSHGETGLOBALFIELD Pervasives, 2
+    1527 APPTERM1 5
+    1529 RESTART 
+    1530 GRAB 1
+    1532 ACC1 
+    1533 BRANCHIFNOT 1549
+    1535 ACC1 
+    1536 GETFIELD0 
+    1537 PUSHACC1 
+    1538 APPLY1 
+    1539 BRANCHIFNOT 1547
+    1541 ACC1 
+    1542 GETFIELD1 
+    1543 PUSHACC1 
+    1544 PUSHOFFSETCLOSURE0 
+    1545 APPTERM2 4
+    1547 RETURN 2
+    1549 CONST1 
+    1550 RETURN 2
+    1552 RESTART 
+    1553 GRAB 1
+    1555 ACC1 
+    1556 BRANCHIFNOT 1570
+    1558 ACC1 
+    1559 GETFIELD0 
+    1560 PUSHACC1 
+    1561 APPLY1 
+    1562 BRANCHIF 1570
+    1564 ACC1 
+    1565 GETFIELD1 
+    1566 PUSHACC1 
+    1567 PUSHOFFSETCLOSURE0 
+    1568 APPTERM2 4
+    1570 RETURN 2
+    1572 RESTART 
+    1573 GRAB 2
+    1575 ACC1 
+    1576 BRANCHIFNOT 1599
+    1578 ACC2 
+    1579 BRANCHIFNOT 1605
+    1581 ACC2 
+    1582 GETFIELD0 
+    1583 PUSHACC2 
+    1584 GETFIELD0 
+    1585 PUSHACC2 
+    1586 APPLY2 
+    1587 BRANCHIFNOT 1597
+    1589 ACC2 
+    1590 GETFIELD1 
+    1591 PUSHACC2 
+    1592 GETFIELD1 
+    1593 PUSHACC2 
+    1594 PUSHOFFSETCLOSURE0 
+    1595 APPTERM3 6
+    1597 RETURN 3
+    1599 ACC2 
+    1600 BRANCHIF 1605
+    1602 CONST1 
+    1603 RETURN 3
+    1605 GETGLOBAL "List.for_all2"
+    1607 PUSHGETGLOBALFIELD Pervasives, 2
+    1610 APPTERM1 4
+    1612 RESTART 
+    1613 GRAB 2
+    1615 ACC1 
+    1616 BRANCHIFNOT 1639
+    1618 ACC2 
+    1619 BRANCHIFNOT 1646
+    1621 ACC2 
+    1622 GETFIELD0 
+    1623 PUSHACC2 
+    1624 GETFIELD0 
+    1625 PUSHACC2 
+    1626 APPLY2 
+    1627 BRANCHIF 1637
+    1629 ACC2 
+    1630 GETFIELD1 
+    1631 PUSHACC2 
+    1632 GETFIELD1 
+    1633 PUSHACC2 
+    1634 PUSHOFFSETCLOSURE0 
+    1635 APPTERM3 6
+    1637 RETURN 3
+    1639 ACC2 
+    1640 BRANCHIFNOT 1644
+    1642 BRANCH 1646
+    1644 RETURN 3
+    1646 GETGLOBAL "List.exists2"
+    1648 PUSHGETGLOBALFIELD Pervasives, 2
+    1651 APPTERM1 4
+    1653 RESTART 
+    1654 GRAB 1
+    1656 ACC1 
+    1657 BRANCHIFNOT 1672
+    1659 ACC0 
+    1660 PUSHACC2 
+    1661 GETFIELD0 
+    1662 C_CALL2 equal
+    1664 BRANCHIF 1672
+    1666 ACC1 
+    1667 GETFIELD1 
+    1668 PUSHACC1 
+    1669 PUSHOFFSETCLOSURE0 
+    1670 APPTERM2 4
+    1672 RETURN 2
+    1674 RESTART 
+    1675 GRAB 1
+    1677 ACC1 
+    1678 BRANCHIFNOT 1692
+    1680 ACC0 
+    1681 PUSHACC2 
+    1682 GETFIELD0 
+    1683 EQ 
+    1684 BRANCHIF 1692
+    1686 ACC1 
+    1687 GETFIELD1 
+    1688 PUSHACC1 
+    1689 PUSHOFFSETCLOSURE0 
+    1690 APPTERM2 4
+    1692 RETURN 2
+    1694 RESTART 
+    1695 GRAB 1
+    1697 ACC1 
+    1698 BRANCHIFNOT 1719
+    1700 ACC1 
+    1701 GETFIELD0 
+    1702 PUSHACC1 
+    1703 PUSHACC1 
+    1704 GETFIELD0 
+    1705 C_CALL2 equal
+    1707 BRANCHIFNOT 1713
+    1709 ACC0 
+    1710 GETFIELD1 
+    1711 RETURN 3
+    1713 ACC2 
+    1714 GETFIELD1 
+    1715 PUSHACC2 
+    1716 PUSHOFFSETCLOSURE0 
+    1717 APPTERM2 5
+    1719 GETGLOBAL Not_found
+    1721 MAKEBLOCK1 0
+    1723 RAISE 
+    1724 RESTART 
+    1725 GRAB 1
+    1727 ACC1 
+    1728 BRANCHIFNOT 1748
+    1730 ACC1 
+    1731 GETFIELD0 
+    1732 PUSHACC1 
+    1733 PUSHACC1 
+    1734 GETFIELD0 
+    1735 EQ 
+    1736 BRANCHIFNOT 1742
+    1738 ACC0 
+    1739 GETFIELD1 
+    1740 RETURN 3
+    1742 ACC2 
+    1743 GETFIELD1 
+    1744 PUSHACC2 
+    1745 PUSHOFFSETCLOSURE0 
+    1746 APPTERM2 5
+    1748 GETGLOBAL Not_found
+    1750 MAKEBLOCK1 0
+    1752 RAISE 
+    1753 RESTART 
+    1754 GRAB 1
+    1756 ACC1 
+    1757 BRANCHIFNOT 1773
+    1759 ACC0 
+    1760 PUSHACC2 
+    1761 GETFIELD0 
+    1762 GETFIELD0 
+    1763 C_CALL2 equal
+    1765 BRANCHIF 1773
+    1767 ACC1 
+    1768 GETFIELD1 
+    1769 PUSHACC1 
+    1770 PUSHOFFSETCLOSURE0 
+    1771 APPTERM2 4
+    1773 RETURN 2
+    1775 RESTART 
+    1776 GRAB 1
+    1778 ACC1 
+    1779 BRANCHIFNOT 1794
+    1781 ACC0 
+    1782 PUSHACC2 
+    1783 GETFIELD0 
+    1784 GETFIELD0 
+    1785 EQ 
+    1786 BRANCHIF 1794
+    1788 ACC1 
+    1789 GETFIELD1 
+    1790 PUSHACC1 
+    1791 PUSHOFFSETCLOSURE0 
+    1792 APPTERM2 4
+    1794 RETURN 2
+    1796 RESTART 
+    1797 GRAB 1
+    1799 ACC1 
+    1800 BRANCHIFNOT 1825
+    1802 ACC1 
+    1803 GETFIELD0 
+    1804 PUSHACC2 
+    1805 GETFIELD1 
+    1806 PUSHACC2 
+    1807 PUSHACC2 
+    1808 GETFIELD0 
+    1809 C_CALL2 equal
+    1811 BRANCHIFNOT 1816
+    1813 ACC0 
+    1814 RETURN 4
+    1816 ACC0 
+    1817 PUSHACC3 
+    1818 PUSHOFFSETCLOSURE0 
+    1819 APPLY2 
+    1820 PUSHACC2 
+    1821 MAKEBLOCK2 0
+    1823 POP 2
+    1825 RETURN 2
+    1827 RESTART 
+    1828 GRAB 1
+    1830 ACC1 
+    1831 BRANCHIFNOT 1855
+    1833 ACC1 
+    1834 GETFIELD0 
+    1835 PUSHACC2 
+    1836 GETFIELD1 
+    1837 PUSHACC2 
+    1838 PUSHACC2 
+    1839 GETFIELD0 
+    1840 EQ 
+    1841 BRANCHIFNOT 1846
+    1843 ACC0 
+    1844 RETURN 4
+    1846 ACC0 
+    1847 PUSHACC3 
+    1848 PUSHOFFSETCLOSURE0 
+    1849 APPLY2 
+    1850 PUSHACC2 
+    1851 MAKEBLOCK2 0
+    1853 POP 2
+    1855 RETURN 2
+    1857 RESTART 
+    1858 GRAB 1
+    1860 ACC1 
+    1861 BRANCHIFNOT 1879
+    1863 ACC1 
+    1864 GETFIELD0 
+    1865 PUSHACC0 
+    1866 PUSHACC2 
+    1867 APPLY1 
+    1868 BRANCHIFNOT 1873
+    1870 ACC0 
+    1871 RETURN 3
+    1873 ACC2 
+    1874 GETFIELD1 
+    1875 PUSHACC2 
+    1876 PUSHOFFSETCLOSURE0 
+    1877 APPTERM2 5
+    1879 GETGLOBAL Not_found
+    1881 MAKEBLOCK1 0
+    1883 RAISE 
+    1884 RESTART 
+    1885 GRAB 2
+    1887 ACC2 
+    1888 BRANCHIFNOT 1917
+    1890 ACC2 
+    1891 GETFIELD0 
+    1892 PUSHACC3 
+    1893 GETFIELD1 
+    1894 PUSHACC1 
+    1895 PUSHENVACC2 
+    1896 APPLY1 
+    1897 BRANCHIFNOT 1908
+    1899 ACC0 
+    1900 PUSHACC4 
+    1901 PUSHACC4 
+    1902 PUSHACC4 
+    1903 MAKEBLOCK2 0
+    1905 PUSHOFFSETCLOSURE0 
+    1906 APPTERM3 8
+    1908 ACC0 
+    1909 PUSHACC4 
+    1910 PUSHACC3 
+    1911 MAKEBLOCK2 0
+    1913 PUSHACC4 
+    1914 PUSHOFFSETCLOSURE0 
+    1915 APPTERM3 8
+    1917 ACC1 
+    1918 PUSHENVACC1 
+    1919 APPLY1 
+    1920 PUSHACC1 
+    1921 PUSHENVACC1 
+    1922 APPLY1 
+    1923 MAKEBLOCK2 0
+    1925 RETURN 3
+    1927 RESTART 
+    1928 GRAB 1
+    1930 ACC0 
+    1931 PUSHENVACC1 
+    1932 CLOSUREREC 2, 1885
+    1936 ACC2 
+    1937 PUSHCONST0 
+    1938 PUSHCONST0 
+    1939 PUSHACC3 
+    1940 APPTERM3 6
+    1942 ACC0 
+    1943 BRANCHIFNOT 1967
+    1945 ACC0 
+    1946 GETFIELD0 
+    1947 PUSHACC1 
+    1948 GETFIELD1 
+    1949 PUSHOFFSETCLOSURE0 
+    1950 APPLY1 
+    1951 PUSHACC0 
+    1952 GETFIELD1 
+    1953 PUSHACC2 
+    1954 GETFIELD1 
+    1955 MAKEBLOCK2 0
+    1957 PUSHACC1 
+    1958 GETFIELD0 
+    1959 PUSHACC3 
+    1960 GETFIELD0 
+    1961 MAKEBLOCK2 0
+    1963 MAKEBLOCK2 0
+    1965 RETURN 3
+    1967 GETGLOBAL <0>(0, 0)
+    1969 RETURN 1
+    1971 RESTART 
+    1972 GRAB 1
+    1974 ACC0 
+    1975 BRANCHIFNOT 1996
+    1977 ACC1 
+    1978 BRANCHIFNOT 2003
+    1980 ACC1 
+    1981 GETFIELD1 
+    1982 PUSHACC1 
+    1983 GETFIELD1 
+    1984 PUSHOFFSETCLOSURE0 
+    1985 APPLY2 
+    1986 PUSHACC2 
+    1987 GETFIELD0 
+    1988 PUSHACC2 
+    1989 GETFIELD0 
+    1990 MAKEBLOCK2 0
+    1992 MAKEBLOCK2 0
+    1994 RETURN 2
+    1996 ACC1 
+    1997 BRANCHIFNOT 2001
+    1999 BRANCH 2003
+    2001 RETURN 2
+    2003 GETGLOBAL "List.combine"
+    2005 PUSHGETGLOBALFIELD Pervasives, 2
+    2008 APPTERM1 3
+    2010 RESTART 
+    2011 GRAB 1
+    2013 ACC1 
+    2014 BRANCHIFNOT 2038
+    2016 ACC1 
+    2017 GETFIELD0 
+    2018 PUSHACC2 
+    2019 GETFIELD1 
+    2020 PUSHACC1 
+    2021 PUSHENVACC2 
+    2022 APPLY1 
+    2023 BRANCHIFNOT 2033
+    2025 ACC0 
+    2026 PUSHACC3 
+    2027 PUSHACC3 
+    2028 MAKEBLOCK2 0
+    2030 PUSHOFFSETCLOSURE0 
+    2031 APPTERM2 6
+    2033 ACC0 
+    2034 PUSHACC3 
+    2035 PUSHOFFSETCLOSURE0 
+    2036 APPTERM2 6
+    2038 ACC0 
+    2039 PUSHENVACC1 
+    2040 APPTERM1 3
+    2042 ACC0 
+    2043 PUSHENVACC1 
+    2044 CLOSUREREC 2, 2011
+    2048 CONST0 
+    2049 PUSHACC1 
+    2050 APPTERM1 3
+    2052 RESTART 
+    2053 GRAB 2
+    2055 ACC1 
+    2056 BRANCHIFNOT 2077
+    2058 ACC2 
+    2059 BRANCHIFNOT 2084
+    2061 ACC2 
+    2062 GETFIELD1 
+    2063 PUSHACC2 
+    2064 GETFIELD1 
+    2065 PUSHACC2 
+    2066 PUSHACC5 
+    2067 GETFIELD0 
+    2068 PUSHACC5 
+    2069 GETFIELD0 
+    2070 PUSHENVACC1 
+    2071 APPLY2 
+    2072 MAKEBLOCK2 0
+    2074 PUSHOFFSETCLOSURE0 
+    2075 APPTERM3 6
+    2077 ACC2 
+    2078 BRANCHIFNOT 2082
+    2080 BRANCH 2084
+    2082 RETURN 3
+    2084 GETGLOBAL "List.rev_map2"
+    2086 PUSHGETGLOBALFIELD Pervasives, 2
+    2089 APPTERM1 4
+    2091 RESTART 
+    2092 GRAB 2
+    2094 ACC0 
+    2095 CLOSUREREC 1, 2053
+    2099 ACC3 
+    2100 PUSHACC3 
+    2101 PUSHCONST0 
+    2102 PUSHACC3 
+    2103 APPTERM3 7
+    2105 RESTART 
+    2106 GRAB 1
+    2108 ACC1 
+    2109 BRANCHIFNOT 2123
+    2111 ACC1 
+    2112 GETFIELD1 
+    2113 PUSHACC1 
+    2114 PUSHACC3 
+    2115 GETFIELD0 
+    2116 PUSHENVACC1 
+    2117 APPLY1 
+    2118 MAKEBLOCK2 0
+    2120 PUSHOFFSETCLOSURE0 
+    2121 APPTERM2 4
+    2123 ACC0 
+    2124 RETURN 2
+    2126 RESTART 
+    2127 GRAB 1
+    2129 ACC0 
+    2130 CLOSUREREC 1, 2106
+    2134 ACC2 
+    2135 PUSHCONST0 
+    2136 PUSHACC2 
+    2137 APPTERM2 5
+    2139 CONST0 
+    2140 PUSHACC1 
+    2141 PUSHENVACC1 
+    2142 APPTERM2 3
+    2144 ACC0 
+    2145 BRANCHIFNOT 2151
+    2147 ACC0 
+    2148 GETFIELD1 
+    2149 RETURN 1
+    2151 GETGLOBAL "tl"
+    2153 PUSHGETGLOBALFIELD Pervasives, 3
+    2156 APPTERM1 2
+    2158 ACC0 
+    2159 BRANCHIFNOT 2165
+    2161 ACC0 
+    2162 GETFIELD0 
+    2163 RETURN 1
+    2165 GETGLOBAL "hd"
+    2167 PUSHGETGLOBALFIELD Pervasives, 3
+    2170 APPTERM1 2
+    2172 ACC0 
+    2173 PUSHCONST0 
+    2174 PUSHENVACC1 
+    2175 APPTERM2 3
+    2177 CLOSUREREC 0, 1200
+    2181 ACC0 
+    2182 CLOSURE 1, 2172
+    2185 PUSH 
+    2186 CLOSURE 0, 2158
+    2189 PUSH 
+    2190 CLOSURE 0, 2144
+    2193 PUSH 
+    2194 CLOSUREREC 0, 1217
+    2198 GETGLOBALFIELD Pervasives, 16
+    2201 PUSH 
+    2202 CLOSUREREC 0, 1259
+    2206 ACC0 
+    2207 CLOSURE 1, 2139
+    2210 PUSH 
+    2211 CLOSUREREC 0, 1277
+    2215 CLOSUREREC 0, 1294
+    2219 CLOSURE 0, 2127
+    2222 PUSH 
+    2223 CLOSUREREC 0, 1316
+    2227 CLOSUREREC 0, 1334
+    2231 CLOSUREREC 0, 1354
+    2235 CLOSUREREC 0, 1374
+    2239 CLOSURE 0, 2092
+    2242 PUSH 
+    2243 CLOSUREREC 0, 1415
+    2247 CLOSUREREC 0, 1452
+    2251 CLOSUREREC 0, 1490
+    2255 CLOSUREREC 0, 1530
+    2259 CLOSUREREC 0, 1553
+    2263 CLOSUREREC 0, 1573
+    2267 CLOSUREREC 0, 1613
+    2271 CLOSUREREC 0, 1654
+    2275 CLOSUREREC 0, 1675
+    2279 CLOSUREREC 0, 1695
+    2283 CLOSUREREC 0, 1725
+    2287 CLOSUREREC 0, 1754
+    2291 CLOSUREREC 0, 1776
+    2295 CLOSUREREC 0, 1797
+    2299 CLOSUREREC 0, 1828
+    2303 CLOSUREREC 0, 1858
+    2307 ACC 24
+    2309 CLOSURE 1, 2042
+    2312 PUSHACC 25
+    2314 CLOSUREREC 1, 1928
+    2318 CLOSUREREC 0, 1942
+    2322 CLOSUREREC 0, 1972
+    2326 ACC0 
+    2327 PUSHACC2 
+    2328 PUSHACC7 
+    2329 PUSHACC 9
+    2331 PUSHACC 11
+    2333 PUSHACC 13
+    2335 PUSHACC 15
+    2337 PUSHACC 17
+    2339 PUSHACC 10
+    2341 PUSHACC 12
+    2343 PUSHACC 13
+    2345 PUSHACC 15
+    2347 PUSHACC 23
+    2349 PUSHACC 25
+    2351 PUSHACC 27
+    2353 PUSHACC 29
+    2355 PUSHACC 31
+    2357 PUSHACC 33
+    2359 PUSHACC 35
+    2361 PUSHACC 37
+    2363 PUSHACC 40
+    2365 PUSHACC 42
+    2367 PUSHACC 41
+    2369 PUSHACC 45
+    2371 PUSHACC 47
+    2373 PUSHACC 50
+    2375 PUSHACC 52
+    2377 PUSHACC 51
+    2379 PUSHACC 55
+    2381 PUSHACC 56
+    2383 PUSHACC 59
+    2385 PUSHACC 61
+    2387 PUSHACC 60
+    2389 PUSHACC 64
+    2391 PUSHACC 66
+    2393 PUSHACC 68
+    2395 PUSHACC 70
+    2397 MAKEBLOCK 37, 0
+    2400 POP 36
+    2402 SETGLOBAL List
+    2404 BRANCH 2432
+    2406 CONST0 
+    2407 PUSHACC1 
+    2408 LEINT 
+    2409 BRANCHIFNOT 2414
+    2411 CONST0 
+    2412 RETURN 1
+    2414 ACC0 
+    2415 OFFSETINT -1
+    2417 PUSHOFFSETCLOSURE0 
+    2418 APPLY1 
+    2419 PUSHACC1 
+    2420 MAKEBLOCK2 0
+    2422 RETURN 1
+    2424 RESTART 
+    2425 GRAB 1
+    2427 ACC1 
+    2428 PUSHACC1 
+    2429 ADDINT 
+    2430 RETURN 2
+    2432 CLOSUREREC 0, 2406
+    2436 CONSTINT 300
+    2438 PUSHACC1 
+    2439 APPLY1 
+    2440 PUSHCONST0 
+    2441 C_CALL1 gc_compaction
+    2443 CONSTINT 150
+    2445 PUSHCONSTINT 301
+    2447 MULINT 
+    2448 PUSHACC1 
+    2449 PUSHCONST0 
+    2450 PUSH 
+    2451 CLOSURE 0, 2425
+    2454 PUSHGETGLOBALFIELD List, 12
+    2457 APPLY3 
+    2458 NEQ 
+    2459 BRANCHIFNOT 2466
+    2461 GETGLOBAL Not_found
+    2463 MAKEBLOCK1 0
+    2465 RAISE 
+    2466 POP 2
+    2468 ATOM0 
+    2469 SETGLOBAL T330-compact-3
+    2471 STOP 
+**)
diff --git a/test/testinterp/t330-compact-4.ml b/test/testinterp/t330-compact-4.ml
new file mode 100644
index 00000000..1c190f75
--- /dev/null
+++ b/test/testinterp/t330-compact-4.ml
@@ -0,0 +1,1589 @@
+open Lib;;
+let rec f n =
+  if n <= 0 then []
+  else n :: f (n-1)
+in
+Gc.compact ();
+let l = f 300 in
+if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 BRANCH 2177
+    1199 RESTART 
+    1200 GRAB 1
+    1202 ACC1 
+    1203 BRANCHIFNOT 1213
+    1205 ACC1 
+    1206 GETFIELD1 
+    1207 PUSHACC1 
+    1208 OFFSETINT 1
+    1210 PUSHOFFSETCLOSURE0 
+    1211 APPTERM2 4
+    1213 ACC0 
+    1214 RETURN 2
+    1216 RESTART 
+    1217 GRAB 1
+    1219 ACC0 
+    1220 BRANCHIFNOT 1251
+    1222 CONST0 
+    1223 PUSHACC2 
+    1224 EQ 
+    1225 BRANCHIFNOT 1231
+    1227 ACC0 
+    1228 GETFIELD0 
+    1229 RETURN 2
+    1231 CONST0 
+    1232 PUSHACC2 
+    1233 GTINT 
+    1234 BRANCHIFNOT 1244
+    1236 ACC1 
+    1237 OFFSETINT -1
+    1239 PUSHACC1 
+    1240 GETFIELD1 
+    1241 PUSHOFFSETCLOSURE0 
+    1242 APPTERM2 4
+    1244 GETGLOBAL "List.nth"
+    1246 PUSHGETGLOBALFIELD Pervasives, 2
+    1249 APPTERM1 3
+    1251 GETGLOBAL "nth"
+    1253 PUSHGETGLOBALFIELD Pervasives, 3
+    1256 APPTERM1 3
+    1258 RESTART 
+    1259 GRAB 1
+    1261 ACC0 
+    1262 BRANCHIFNOT 1274
+    1264 ACC1 
+    1265 PUSHACC1 
+    1266 GETFIELD0 
+    1267 MAKEBLOCK2 0
+    1269 PUSHACC1 
+    1270 GETFIELD1 
+    1271 PUSHOFFSETCLOSURE0 
+    1272 APPTERM2 4
+    1274 ACC1 
+    1275 RETURN 2
+    1277 ACC0 
+    1278 BRANCHIFNOT 1291
+    1280 ACC0 
+    1281 GETFIELD1 
+    1282 PUSHOFFSETCLOSURE0 
+    1283 APPLY1 
+    1284 PUSHACC1 
+    1285 GETFIELD0 
+    1286 PUSHGETGLOBALFIELD Pervasives, 16
+    1289 APPTERM2 3
+    1291 RETURN 1
+    1293 RESTART 
+    1294 GRAB 1
+    1296 ACC1 
+    1297 BRANCHIFNOT 1313
+    1299 ACC1 
+    1300 GETFIELD0 
+    1301 PUSHACC1 
+    1302 APPLY1 
+    1303 PUSHACC2 
+    1304 GETFIELD1 
+    1305 PUSHACC2 
+    1306 PUSHOFFSETCLOSURE0 
+    1307 APPLY2 
+    1308 PUSHACC1 
+    1309 MAKEBLOCK2 0
+    1311 POP 1
+    1313 RETURN 2
+    1315 RESTART 
+    1316 GRAB 1
+    1318 ACC1 
+    1319 BRANCHIFNOT 1331
+    1321 ACC1 
+    1322 GETFIELD0 
+    1323 PUSHACC1 
+    1324 APPLY1 
+    1325 ACC1 
+    1326 GETFIELD1 
+    1327 PUSHACC1 
+    1328 PUSHOFFSETCLOSURE0 
+    1329 APPTERM2 4
+    1331 RETURN 2
+    1333 RESTART 
+    1334 GRAB 2
+    1336 ACC2 
+    1337 BRANCHIFNOT 1350
+    1339 ACC2 
+    1340 GETFIELD1 
+    1341 PUSHACC3 
+    1342 GETFIELD0 
+    1343 PUSHACC3 
+    1344 PUSHACC3 
+    1345 APPLY2 
+    1346 PUSHACC2 
+    1347 PUSHOFFSETCLOSURE0 
+    1348 APPTERM3 6
+    1350 ACC1 
+    1351 RETURN 3
+    1353 RESTART 
+    1354 GRAB 2
+    1356 ACC1 
+    1357 BRANCHIFNOT 1370
+    1359 ACC2 
+    1360 PUSHACC2 
+    1361 GETFIELD1 
+    1362 PUSHACC2 
+    1363 PUSHOFFSETCLOSURE0 
+    1364 APPLY3 
+    1365 PUSHACC2 
+    1366 GETFIELD0 
+    1367 PUSHACC2 
+    1368 APPTERM2 5
+    1370 ACC2 
+    1371 RETURN 3
+    1373 RESTART 
+    1374 GRAB 2
+    1376 ACC1 
+    1377 BRANCHIFNOT 1400
+    1379 ACC2 
+    1380 BRANCHIFNOT 1407
+    1382 ACC2 
+    1383 GETFIELD0 
+    1384 PUSHACC2 
+    1385 GETFIELD0 
+    1386 PUSHACC2 
+    1387 APPLY2 
+    1388 PUSHACC3 
+    1389 GETFIELD1 
+    1390 PUSHACC3 
+    1391 GETFIELD1 
+    1392 PUSHACC3 
+    1393 PUSHOFFSETCLOSURE0 
+    1394 APPLY3 
+    1395 PUSHACC1 
+    1396 MAKEBLOCK2 0
+    1398 RETURN 4
+    1400 ACC2 
+    1401 BRANCHIFNOT 1405
+    1403 BRANCH 1407
+    1405 RETURN 3
+    1407 GETGLOBAL "List.map2"
+    1409 PUSHGETGLOBALFIELD Pervasives, 2
+    1412 APPTERM1 4
+    1414 RESTART 
+    1415 GRAB 2
+    1417 ACC1 
+    1418 BRANCHIFNOT 1437
+    1420 ACC2 
+    1421 BRANCHIFNOT 1444
+    1423 ACC2 
+    1424 GETFIELD0 
+    1425 PUSHACC2 
+    1426 GETFIELD0 
+    1427 PUSHACC2 
+    1428 APPLY2 
+    1429 ACC2 
+    1430 GETFIELD1 
+    1431 PUSHACC2 
+    1432 GETFIELD1 
+    1433 PUSHACC2 
+    1434 PUSHOFFSETCLOSURE0 
+    1435 APPTERM3 6
+    1437 ACC2 
+    1438 BRANCHIFNOT 1442
+    1440 BRANCH 1444
+    1442 RETURN 3
+    1444 GETGLOBAL "List.iter2"
+    1446 PUSHGETGLOBALFIELD Pervasives, 2
+    1449 APPTERM1 4
+    1451 RESTART 
+    1452 GRAB 3
+    1454 ACC2 
+    1455 BRANCHIFNOT 1476
+    1457 ACC3 
+    1458 BRANCHIFNOT 1482
+    1460 ACC3 
+    1461 GETFIELD1 
+    1462 PUSHACC3 
+    1463 GETFIELD1 
+    1464 PUSHACC5 
+    1465 GETFIELD0 
+    1466 PUSHACC5 
+    1467 GETFIELD0 
+    1468 PUSHACC5 
+    1469 PUSHACC5 
+    1470 APPLY3 
+    1471 PUSHACC3 
+    1472 PUSHOFFSETCLOSURE0 
+    1473 APPTERM 4, 8
+    1476 ACC3 
+    1477 BRANCHIF 1482
+    1479 ACC1 
+    1480 RETURN 4
+    1482 GETGLOBAL "List.fold_left2"
+    1484 PUSHGETGLOBALFIELD Pervasives, 2
+    1487 APPTERM1 5
+    1489 RESTART 
+    1490 GRAB 3
+    1492 ACC1 
+    1493 BRANCHIFNOT 1516
+    1495 ACC2 
+    1496 BRANCHIFNOT 1522
+    1498 PUSH_RETADDR 1509
+    1500 ACC6 
+    1501 PUSHACC6 
+    1502 GETFIELD1 
+    1503 PUSHACC6 
+    1504 GETFIELD1 
+    1505 PUSHACC6 
+    1506 PUSHOFFSETCLOSURE0 
+    1507 APPLY 4
+    1509 PUSHACC3 
+    1510 GETFIELD0 
+    1511 PUSHACC3 
+    1512 GETFIELD0 
+    1513 PUSHACC3 
+    1514 APPTERM3 7
+    1516 ACC2 
+    1517 BRANCHIF 1522
+    1519 ACC3 
+    1520 RETURN 4
+    1522 GETGLOBAL "List.fold_right2"
+    1524 PUSHGETGLOBALFIELD Pervasives, 2
+    1527 APPTERM1 5
+    1529 RESTART 
+    1530 GRAB 1
+    1532 ACC1 
+    1533 BRANCHIFNOT 1549
+    1535 ACC1 
+    1536 GETFIELD0 
+    1537 PUSHACC1 
+    1538 APPLY1 
+    1539 BRANCHIFNOT 1547
+    1541 ACC1 
+    1542 GETFIELD1 
+    1543 PUSHACC1 
+    1544 PUSHOFFSETCLOSURE0 
+    1545 APPTERM2 4
+    1547 RETURN 2
+    1549 CONST1 
+    1550 RETURN 2
+    1552 RESTART 
+    1553 GRAB 1
+    1555 ACC1 
+    1556 BRANCHIFNOT 1570
+    1558 ACC1 
+    1559 GETFIELD0 
+    1560 PUSHACC1 
+    1561 APPLY1 
+    1562 BRANCHIF 1570
+    1564 ACC1 
+    1565 GETFIELD1 
+    1566 PUSHACC1 
+    1567 PUSHOFFSETCLOSURE0 
+    1568 APPTERM2 4
+    1570 RETURN 2
+    1572 RESTART 
+    1573 GRAB 2
+    1575 ACC1 
+    1576 BRANCHIFNOT 1599
+    1578 ACC2 
+    1579 BRANCHIFNOT 1605
+    1581 ACC2 
+    1582 GETFIELD0 
+    1583 PUSHACC2 
+    1584 GETFIELD0 
+    1585 PUSHACC2 
+    1586 APPLY2 
+    1587 BRANCHIFNOT 1597
+    1589 ACC2 
+    1590 GETFIELD1 
+    1591 PUSHACC2 
+    1592 GETFIELD1 
+    1593 PUSHACC2 
+    1594 PUSHOFFSETCLOSURE0 
+    1595 APPTERM3 6
+    1597 RETURN 3
+    1599 ACC2 
+    1600 BRANCHIF 1605
+    1602 CONST1 
+    1603 RETURN 3
+    1605 GETGLOBAL "List.for_all2"
+    1607 PUSHGETGLOBALFIELD Pervasives, 2
+    1610 APPTERM1 4
+    1612 RESTART 
+    1613 GRAB 2
+    1615 ACC1 
+    1616 BRANCHIFNOT 1639
+    1618 ACC2 
+    1619 BRANCHIFNOT 1646
+    1621 ACC2 
+    1622 GETFIELD0 
+    1623 PUSHACC2 
+    1624 GETFIELD0 
+    1625 PUSHACC2 
+    1626 APPLY2 
+    1627 BRANCHIF 1637
+    1629 ACC2 
+    1630 GETFIELD1 
+    1631 PUSHACC2 
+    1632 GETFIELD1 
+    1633 PUSHACC2 
+    1634 PUSHOFFSETCLOSURE0 
+    1635 APPTERM3 6
+    1637 RETURN 3
+    1639 ACC2 
+    1640 BRANCHIFNOT 1644
+    1642 BRANCH 1646
+    1644 RETURN 3
+    1646 GETGLOBAL "List.exists2"
+    1648 PUSHGETGLOBALFIELD Pervasives, 2
+    1651 APPTERM1 4
+    1653 RESTART 
+    1654 GRAB 1
+    1656 ACC1 
+    1657 BRANCHIFNOT 1672
+    1659 ACC0 
+    1660 PUSHACC2 
+    1661 GETFIELD0 
+    1662 C_CALL2 equal
+    1664 BRANCHIF 1672
+    1666 ACC1 
+    1667 GETFIELD1 
+    1668 PUSHACC1 
+    1669 PUSHOFFSETCLOSURE0 
+    1670 APPTERM2 4
+    1672 RETURN 2
+    1674 RESTART 
+    1675 GRAB 1
+    1677 ACC1 
+    1678 BRANCHIFNOT 1692
+    1680 ACC0 
+    1681 PUSHACC2 
+    1682 GETFIELD0 
+    1683 EQ 
+    1684 BRANCHIF 1692
+    1686 ACC1 
+    1687 GETFIELD1 
+    1688 PUSHACC1 
+    1689 PUSHOFFSETCLOSURE0 
+    1690 APPTERM2 4
+    1692 RETURN 2
+    1694 RESTART 
+    1695 GRAB 1
+    1697 ACC1 
+    1698 BRANCHIFNOT 1719
+    1700 ACC1 
+    1701 GETFIELD0 
+    1702 PUSHACC1 
+    1703 PUSHACC1 
+    1704 GETFIELD0 
+    1705 C_CALL2 equal
+    1707 BRANCHIFNOT 1713
+    1709 ACC0 
+    1710 GETFIELD1 
+    1711 RETURN 3
+    1713 ACC2 
+    1714 GETFIELD1 
+    1715 PUSHACC2 
+    1716 PUSHOFFSETCLOSURE0 
+    1717 APPTERM2 5
+    1719 GETGLOBAL Not_found
+    1721 MAKEBLOCK1 0
+    1723 RAISE 
+    1724 RESTART 
+    1725 GRAB 1
+    1727 ACC1 
+    1728 BRANCHIFNOT 1748
+    1730 ACC1 
+    1731 GETFIELD0 
+    1732 PUSHACC1 
+    1733 PUSHACC1 
+    1734 GETFIELD0 
+    1735 EQ 
+    1736 BRANCHIFNOT 1742
+    1738 ACC0 
+    1739 GETFIELD1 
+    1740 RETURN 3
+    1742 ACC2 
+    1743 GETFIELD1 
+    1744 PUSHACC2 
+    1745 PUSHOFFSETCLOSURE0 
+    1746 APPTERM2 5
+    1748 GETGLOBAL Not_found
+    1750 MAKEBLOCK1 0
+    1752 RAISE 
+    1753 RESTART 
+    1754 GRAB 1
+    1756 ACC1 
+    1757 BRANCHIFNOT 1773
+    1759 ACC0 
+    1760 PUSHACC2 
+    1761 GETFIELD0 
+    1762 GETFIELD0 
+    1763 C_CALL2 equal
+    1765 BRANCHIF 1773
+    1767 ACC1 
+    1768 GETFIELD1 
+    1769 PUSHACC1 
+    1770 PUSHOFFSETCLOSURE0 
+    1771 APPTERM2 4
+    1773 RETURN 2
+    1775 RESTART 
+    1776 GRAB 1
+    1778 ACC1 
+    1779 BRANCHIFNOT 1794
+    1781 ACC0 
+    1782 PUSHACC2 
+    1783 GETFIELD0 
+    1784 GETFIELD0 
+    1785 EQ 
+    1786 BRANCHIF 1794
+    1788 ACC1 
+    1789 GETFIELD1 
+    1790 PUSHACC1 
+    1791 PUSHOFFSETCLOSURE0 
+    1792 APPTERM2 4
+    1794 RETURN 2
+    1796 RESTART 
+    1797 GRAB 1
+    1799 ACC1 
+    1800 BRANCHIFNOT 1825
+    1802 ACC1 
+    1803 GETFIELD0 
+    1804 PUSHACC2 
+    1805 GETFIELD1 
+    1806 PUSHACC2 
+    1807 PUSHACC2 
+    1808 GETFIELD0 
+    1809 C_CALL2 equal
+    1811 BRANCHIFNOT 1816
+    1813 ACC0 
+    1814 RETURN 4
+    1816 ACC0 
+    1817 PUSHACC3 
+    1818 PUSHOFFSETCLOSURE0 
+    1819 APPLY2 
+    1820 PUSHACC2 
+    1821 MAKEBLOCK2 0
+    1823 POP 2
+    1825 RETURN 2
+    1827 RESTART 
+    1828 GRAB 1
+    1830 ACC1 
+    1831 BRANCHIFNOT 1855
+    1833 ACC1 
+    1834 GETFIELD0 
+    1835 PUSHACC2 
+    1836 GETFIELD1 
+    1837 PUSHACC2 
+    1838 PUSHACC2 
+    1839 GETFIELD0 
+    1840 EQ 
+    1841 BRANCHIFNOT 1846
+    1843 ACC0 
+    1844 RETURN 4
+    1846 ACC0 
+    1847 PUSHACC3 
+    1848 PUSHOFFSETCLOSURE0 
+    1849 APPLY2 
+    1850 PUSHACC2 
+    1851 MAKEBLOCK2 0
+    1853 POP 2
+    1855 RETURN 2
+    1857 RESTART 
+    1858 GRAB 1
+    1860 ACC1 
+    1861 BRANCHIFNOT 1879
+    1863 ACC1 
+    1864 GETFIELD0 
+    1865 PUSHACC0 
+    1866 PUSHACC2 
+    1867 APPLY1 
+    1868 BRANCHIFNOT 1873
+    1870 ACC0 
+    1871 RETURN 3
+    1873 ACC2 
+    1874 GETFIELD1 
+    1875 PUSHACC2 
+    1876 PUSHOFFSETCLOSURE0 
+    1877 APPTERM2 5
+    1879 GETGLOBAL Not_found
+    1881 MAKEBLOCK1 0
+    1883 RAISE 
+    1884 RESTART 
+    1885 GRAB 2
+    1887 ACC2 
+    1888 BRANCHIFNOT 1917
+    1890 ACC2 
+    1891 GETFIELD0 
+    1892 PUSHACC3 
+    1893 GETFIELD1 
+    1894 PUSHACC1 
+    1895 PUSHENVACC2 
+    1896 APPLY1 
+    1897 BRANCHIFNOT 1908
+    1899 ACC0 
+    1900 PUSHACC4 
+    1901 PUSHACC4 
+    1902 PUSHACC4 
+    1903 MAKEBLOCK2 0
+    1905 PUSHOFFSETCLOSURE0 
+    1906 APPTERM3 8
+    1908 ACC0 
+    1909 PUSHACC4 
+    1910 PUSHACC3 
+    1911 MAKEBLOCK2 0
+    1913 PUSHACC4 
+    1914 PUSHOFFSETCLOSURE0 
+    1915 APPTERM3 8
+    1917 ACC1 
+    1918 PUSHENVACC1 
+    1919 APPLY1 
+    1920 PUSHACC1 
+    1921 PUSHENVACC1 
+    1922 APPLY1 
+    1923 MAKEBLOCK2 0
+    1925 RETURN 3
+    1927 RESTART 
+    1928 GRAB 1
+    1930 ACC0 
+    1931 PUSHENVACC1 
+    1932 CLOSUREREC 2, 1885
+    1936 ACC2 
+    1937 PUSHCONST0 
+    1938 PUSHCONST0 
+    1939 PUSHACC3 
+    1940 APPTERM3 6
+    1942 ACC0 
+    1943 BRANCHIFNOT 1967
+    1945 ACC0 
+    1946 GETFIELD0 
+    1947 PUSHACC1 
+    1948 GETFIELD1 
+    1949 PUSHOFFSETCLOSURE0 
+    1950 APPLY1 
+    1951 PUSHACC0 
+    1952 GETFIELD1 
+    1953 PUSHACC2 
+    1954 GETFIELD1 
+    1955 MAKEBLOCK2 0
+    1957 PUSHACC1 
+    1958 GETFIELD0 
+    1959 PUSHACC3 
+    1960 GETFIELD0 
+    1961 MAKEBLOCK2 0
+    1963 MAKEBLOCK2 0
+    1965 RETURN 3
+    1967 GETGLOBAL <0>(0, 0)
+    1969 RETURN 1
+    1971 RESTART 
+    1972 GRAB 1
+    1974 ACC0 
+    1975 BRANCHIFNOT 1996
+    1977 ACC1 
+    1978 BRANCHIFNOT 2003
+    1980 ACC1 
+    1981 GETFIELD1 
+    1982 PUSHACC1 
+    1983 GETFIELD1 
+    1984 PUSHOFFSETCLOSURE0 
+    1985 APPLY2 
+    1986 PUSHACC2 
+    1987 GETFIELD0 
+    1988 PUSHACC2 
+    1989 GETFIELD0 
+    1990 MAKEBLOCK2 0
+    1992 MAKEBLOCK2 0
+    1994 RETURN 2
+    1996 ACC1 
+    1997 BRANCHIFNOT 2001
+    1999 BRANCH 2003
+    2001 RETURN 2
+    2003 GETGLOBAL "List.combine"
+    2005 PUSHGETGLOBALFIELD Pervasives, 2
+    2008 APPTERM1 3
+    2010 RESTART 
+    2011 GRAB 1
+    2013 ACC1 
+    2014 BRANCHIFNOT 2038
+    2016 ACC1 
+    2017 GETFIELD0 
+    2018 PUSHACC2 
+    2019 GETFIELD1 
+    2020 PUSHACC1 
+    2021 PUSHENVACC2 
+    2022 APPLY1 
+    2023 BRANCHIFNOT 2033
+    2025 ACC0 
+    2026 PUSHACC3 
+    2027 PUSHACC3 
+    2028 MAKEBLOCK2 0
+    2030 PUSHOFFSETCLOSURE0 
+    2031 APPTERM2 6
+    2033 ACC0 
+    2034 PUSHACC3 
+    2035 PUSHOFFSETCLOSURE0 
+    2036 APPTERM2 6
+    2038 ACC0 
+    2039 PUSHENVACC1 
+    2040 APPTERM1 3
+    2042 ACC0 
+    2043 PUSHENVACC1 
+    2044 CLOSUREREC 2, 2011
+    2048 CONST0 
+    2049 PUSHACC1 
+    2050 APPTERM1 3
+    2052 RESTART 
+    2053 GRAB 2
+    2055 ACC1 
+    2056 BRANCHIFNOT 2077
+    2058 ACC2 
+    2059 BRANCHIFNOT 2084
+    2061 ACC2 
+    2062 GETFIELD1 
+    2063 PUSHACC2 
+    2064 GETFIELD1 
+    2065 PUSHACC2 
+    2066 PUSHACC5 
+    2067 GETFIELD0 
+    2068 PUSHACC5 
+    2069 GETFIELD0 
+    2070 PUSHENVACC1 
+    2071 APPLY2 
+    2072 MAKEBLOCK2 0
+    2074 PUSHOFFSETCLOSURE0 
+    2075 APPTERM3 6
+    2077 ACC2 
+    2078 BRANCHIFNOT 2082
+    2080 BRANCH 2084
+    2082 RETURN 3
+    2084 GETGLOBAL "List.rev_map2"
+    2086 PUSHGETGLOBALFIELD Pervasives, 2
+    2089 APPTERM1 4
+    2091 RESTART 
+    2092 GRAB 2
+    2094 ACC0 
+    2095 CLOSUREREC 1, 2053
+    2099 ACC3 
+    2100 PUSHACC3 
+    2101 PUSHCONST0 
+    2102 PUSHACC3 
+    2103 APPTERM3 7
+    2105 RESTART 
+    2106 GRAB 1
+    2108 ACC1 
+    2109 BRANCHIFNOT 2123
+    2111 ACC1 
+    2112 GETFIELD1 
+    2113 PUSHACC1 
+    2114 PUSHACC3 
+    2115 GETFIELD0 
+    2116 PUSHENVACC1 
+    2117 APPLY1 
+    2118 MAKEBLOCK2 0
+    2120 PUSHOFFSETCLOSURE0 
+    2121 APPTERM2 4
+    2123 ACC0 
+    2124 RETURN 2
+    2126 RESTART 
+    2127 GRAB 1
+    2129 ACC0 
+    2130 CLOSUREREC 1, 2106
+    2134 ACC2 
+    2135 PUSHCONST0 
+    2136 PUSHACC2 
+    2137 APPTERM2 5
+    2139 CONST0 
+    2140 PUSHACC1 
+    2141 PUSHENVACC1 
+    2142 APPTERM2 3
+    2144 ACC0 
+    2145 BRANCHIFNOT 2151
+    2147 ACC0 
+    2148 GETFIELD1 
+    2149 RETURN 1
+    2151 GETGLOBAL "tl"
+    2153 PUSHGETGLOBALFIELD Pervasives, 3
+    2156 APPTERM1 2
+    2158 ACC0 
+    2159 BRANCHIFNOT 2165
+    2161 ACC0 
+    2162 GETFIELD0 
+    2163 RETURN 1
+    2165 GETGLOBAL "hd"
+    2167 PUSHGETGLOBALFIELD Pervasives, 3
+    2170 APPTERM1 2
+    2172 ACC0 
+    2173 PUSHCONST0 
+    2174 PUSHENVACC1 
+    2175 APPTERM2 3
+    2177 CLOSUREREC 0, 1200
+    2181 ACC0 
+    2182 CLOSURE 1, 2172
+    2185 PUSH 
+    2186 CLOSURE 0, 2158
+    2189 PUSH 
+    2190 CLOSURE 0, 2144
+    2193 PUSH 
+    2194 CLOSUREREC 0, 1217
+    2198 GETGLOBALFIELD Pervasives, 16
+    2201 PUSH 
+    2202 CLOSUREREC 0, 1259
+    2206 ACC0 
+    2207 CLOSURE 1, 2139
+    2210 PUSH 
+    2211 CLOSUREREC 0, 1277
+    2215 CLOSUREREC 0, 1294
+    2219 CLOSURE 0, 2127
+    2222 PUSH 
+    2223 CLOSUREREC 0, 1316
+    2227 CLOSUREREC 0, 1334
+    2231 CLOSUREREC 0, 1354
+    2235 CLOSUREREC 0, 1374
+    2239 CLOSURE 0, 2092
+    2242 PUSH 
+    2243 CLOSUREREC 0, 1415
+    2247 CLOSUREREC 0, 1452
+    2251 CLOSUREREC 0, 1490
+    2255 CLOSUREREC 0, 1530
+    2259 CLOSUREREC 0, 1553
+    2263 CLOSUREREC 0, 1573
+    2267 CLOSUREREC 0, 1613
+    2271 CLOSUREREC 0, 1654
+    2275 CLOSUREREC 0, 1675
+    2279 CLOSUREREC 0, 1695
+    2283 CLOSUREREC 0, 1725
+    2287 CLOSUREREC 0, 1754
+    2291 CLOSUREREC 0, 1776
+    2295 CLOSUREREC 0, 1797
+    2299 CLOSUREREC 0, 1828
+    2303 CLOSUREREC 0, 1858
+    2307 ACC 24
+    2309 CLOSURE 1, 2042
+    2312 PUSHACC 25
+    2314 CLOSUREREC 1, 1928
+    2318 CLOSUREREC 0, 1942
+    2322 CLOSUREREC 0, 1972
+    2326 ACC0 
+    2327 PUSHACC2 
+    2328 PUSHACC7 
+    2329 PUSHACC 9
+    2331 PUSHACC 11
+    2333 PUSHACC 13
+    2335 PUSHACC 15
+    2337 PUSHACC 17
+    2339 PUSHACC 10
+    2341 PUSHACC 12
+    2343 PUSHACC 13
+    2345 PUSHACC 15
+    2347 PUSHACC 23
+    2349 PUSHACC 25
+    2351 PUSHACC 27
+    2353 PUSHACC 29
+    2355 PUSHACC 31
+    2357 PUSHACC 33
+    2359 PUSHACC 35
+    2361 PUSHACC 37
+    2363 PUSHACC 40
+    2365 PUSHACC 42
+    2367 PUSHACC 41
+    2369 PUSHACC 45
+    2371 PUSHACC 47
+    2373 PUSHACC 50
+    2375 PUSHACC 52
+    2377 PUSHACC 51
+    2379 PUSHACC 55
+    2381 PUSHACC 56
+    2383 PUSHACC 59
+    2385 PUSHACC 61
+    2387 PUSHACC 60
+    2389 PUSHACC 64
+    2391 PUSHACC 66
+    2393 PUSHACC 68
+    2395 PUSHACC 70
+    2397 MAKEBLOCK 37, 0
+    2400 POP 36
+    2402 SETGLOBAL List
+    2404 BRANCH 2432
+    2406 CONST0 
+    2407 PUSHACC1 
+    2408 LEINT 
+    2409 BRANCHIFNOT 2414
+    2411 CONST0 
+    2412 RETURN 1
+    2414 ACC0 
+    2415 OFFSETINT -1
+    2417 PUSHOFFSETCLOSURE0 
+    2418 APPLY1 
+    2419 PUSHACC1 
+    2420 MAKEBLOCK2 0
+    2422 RETURN 1
+    2424 RESTART 
+    2425 GRAB 1
+    2427 ACC1 
+    2428 PUSHACC1 
+    2429 ADDINT 
+    2430 RETURN 2
+    2432 CLOSUREREC 0, 2406
+    2436 CONST0 
+    2437 C_CALL1 gc_compaction
+    2439 CONSTINT 300
+    2441 PUSHACC1 
+    2442 APPLY1 
+    2443 PUSHCONSTINT 150
+    2445 PUSHCONSTINT 301
+    2447 MULINT 
+    2448 PUSHACC1 
+    2449 PUSHCONST0 
+    2450 PUSH 
+    2451 CLOSURE 0, 2425
+    2454 PUSHGETGLOBALFIELD List, 12
+    2457 APPLY3 
+    2458 NEQ 
+    2459 BRANCHIFNOT 2466
+    2461 GETGLOBAL Not_found
+    2463 MAKEBLOCK1 0
+    2465 RAISE 
+    2466 POP 2
+    2468 ATOM0 
+    2469 SETGLOBAL T330-compact-4
+    2471 STOP 
+**)
diff --git a/test/testinterp/t340-weak.ml b/test/testinterp/t340-weak.ml
new file mode 100644
index 00000000..e36dbab5
--- /dev/null
+++ b/test/testinterp/t340-weak.ml
@@ -0,0 +1,2551 @@
+open Lib;;
+let x = Array.make 20 "" in
+let w = weak_create 20 in
+for i = 0 to 19 do
+  x.(i) <- String.make 20 's';
+  weak_set w i (Some x.(i));
+done;
+Gc.full_major ();
+for i = 0 to 19 do
+  match weak_get w i with
+  | None -> raise Not_found
+  | _ -> ()
+done;
+for i = 0 to 19 do
+  if i mod 2 = 0 then x.(i) <- ""
+done;
+Gc.full_major ();
+for i = 0 to 19 do
+  match weak_get w i with
+  | None when i mod 2 = 0 -> ()
+  | Some s when i mod 2 = 1 -> if s.[5] <> 's' then raise Not_found
+  | _ -> raise Not_found
+done
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 BRANCH 2177
+    1199 RESTART 
+    1200 GRAB 1
+    1202 ACC1 
+    1203 BRANCHIFNOT 1213
+    1205 ACC1 
+    1206 GETFIELD1 
+    1207 PUSHACC1 
+    1208 OFFSETINT 1
+    1210 PUSHOFFSETCLOSURE0 
+    1211 APPTERM2 4
+    1213 ACC0 
+    1214 RETURN 2
+    1216 RESTART 
+    1217 GRAB 1
+    1219 ACC0 
+    1220 BRANCHIFNOT 1251
+    1222 CONST0 
+    1223 PUSHACC2 
+    1224 EQ 
+    1225 BRANCHIFNOT 1231
+    1227 ACC0 
+    1228 GETFIELD0 
+    1229 RETURN 2
+    1231 CONST0 
+    1232 PUSHACC2 
+    1233 GTINT 
+    1234 BRANCHIFNOT 1244
+    1236 ACC1 
+    1237 OFFSETINT -1
+    1239 PUSHACC1 
+    1240 GETFIELD1 
+    1241 PUSHOFFSETCLOSURE0 
+    1242 APPTERM2 4
+    1244 GETGLOBAL "List.nth"
+    1246 PUSHGETGLOBALFIELD Pervasives, 2
+    1249 APPTERM1 3
+    1251 GETGLOBAL "nth"
+    1253 PUSHGETGLOBALFIELD Pervasives, 3
+    1256 APPTERM1 3
+    1258 RESTART 
+    1259 GRAB 1
+    1261 ACC0 
+    1262 BRANCHIFNOT 1274
+    1264 ACC1 
+    1265 PUSHACC1 
+    1266 GETFIELD0 
+    1267 MAKEBLOCK2 0
+    1269 PUSHACC1 
+    1270 GETFIELD1 
+    1271 PUSHOFFSETCLOSURE0 
+    1272 APPTERM2 4
+    1274 ACC1 
+    1275 RETURN 2
+    1277 ACC0 
+    1278 BRANCHIFNOT 1291
+    1280 ACC0 
+    1281 GETFIELD1 
+    1282 PUSHOFFSETCLOSURE0 
+    1283 APPLY1 
+    1284 PUSHACC1 
+    1285 GETFIELD0 
+    1286 PUSHGETGLOBALFIELD Pervasives, 16
+    1289 APPTERM2 3
+    1291 RETURN 1
+    1293 RESTART 
+    1294 GRAB 1
+    1296 ACC1 
+    1297 BRANCHIFNOT 1313
+    1299 ACC1 
+    1300 GETFIELD0 
+    1301 PUSHACC1 
+    1302 APPLY1 
+    1303 PUSHACC2 
+    1304 GETFIELD1 
+    1305 PUSHACC2 
+    1306 PUSHOFFSETCLOSURE0 
+    1307 APPLY2 
+    1308 PUSHACC1 
+    1309 MAKEBLOCK2 0
+    1311 POP 1
+    1313 RETURN 2
+    1315 RESTART 
+    1316 GRAB 1
+    1318 ACC1 
+    1319 BRANCHIFNOT 1331
+    1321 ACC1 
+    1322 GETFIELD0 
+    1323 PUSHACC1 
+    1324 APPLY1 
+    1325 ACC1 
+    1326 GETFIELD1 
+    1327 PUSHACC1 
+    1328 PUSHOFFSETCLOSURE0 
+    1329 APPTERM2 4
+    1331 RETURN 2
+    1333 RESTART 
+    1334 GRAB 2
+    1336 ACC2 
+    1337 BRANCHIFNOT 1350
+    1339 ACC2 
+    1340 GETFIELD1 
+    1341 PUSHACC3 
+    1342 GETFIELD0 
+    1343 PUSHACC3 
+    1344 PUSHACC3 
+    1345 APPLY2 
+    1346 PUSHACC2 
+    1347 PUSHOFFSETCLOSURE0 
+    1348 APPTERM3 6
+    1350 ACC1 
+    1351 RETURN 3
+    1353 RESTART 
+    1354 GRAB 2
+    1356 ACC1 
+    1357 BRANCHIFNOT 1370
+    1359 ACC2 
+    1360 PUSHACC2 
+    1361 GETFIELD1 
+    1362 PUSHACC2 
+    1363 PUSHOFFSETCLOSURE0 
+    1364 APPLY3 
+    1365 PUSHACC2 
+    1366 GETFIELD0 
+    1367 PUSHACC2 
+    1368 APPTERM2 5
+    1370 ACC2 
+    1371 RETURN 3
+    1373 RESTART 
+    1374 GRAB 2
+    1376 ACC1 
+    1377 BRANCHIFNOT 1400
+    1379 ACC2 
+    1380 BRANCHIFNOT 1407
+    1382 ACC2 
+    1383 GETFIELD0 
+    1384 PUSHACC2 
+    1385 GETFIELD0 
+    1386 PUSHACC2 
+    1387 APPLY2 
+    1388 PUSHACC3 
+    1389 GETFIELD1 
+    1390 PUSHACC3 
+    1391 GETFIELD1 
+    1392 PUSHACC3 
+    1393 PUSHOFFSETCLOSURE0 
+    1394 APPLY3 
+    1395 PUSHACC1 
+    1396 MAKEBLOCK2 0
+    1398 RETURN 4
+    1400 ACC2 
+    1401 BRANCHIFNOT 1405
+    1403 BRANCH 1407
+    1405 RETURN 3
+    1407 GETGLOBAL "List.map2"
+    1409 PUSHGETGLOBALFIELD Pervasives, 2
+    1412 APPTERM1 4
+    1414 RESTART 
+    1415 GRAB 2
+    1417 ACC1 
+    1418 BRANCHIFNOT 1437
+    1420 ACC2 
+    1421 BRANCHIFNOT 1444
+    1423 ACC2 
+    1424 GETFIELD0 
+    1425 PUSHACC2 
+    1426 GETFIELD0 
+    1427 PUSHACC2 
+    1428 APPLY2 
+    1429 ACC2 
+    1430 GETFIELD1 
+    1431 PUSHACC2 
+    1432 GETFIELD1 
+    1433 PUSHACC2 
+    1434 PUSHOFFSETCLOSURE0 
+    1435 APPTERM3 6
+    1437 ACC2 
+    1438 BRANCHIFNOT 1442
+    1440 BRANCH 1444
+    1442 RETURN 3
+    1444 GETGLOBAL "List.iter2"
+    1446 PUSHGETGLOBALFIELD Pervasives, 2
+    1449 APPTERM1 4
+    1451 RESTART 
+    1452 GRAB 3
+    1454 ACC2 
+    1455 BRANCHIFNOT 1476
+    1457 ACC3 
+    1458 BRANCHIFNOT 1482
+    1460 ACC3 
+    1461 GETFIELD1 
+    1462 PUSHACC3 
+    1463 GETFIELD1 
+    1464 PUSHACC5 
+    1465 GETFIELD0 
+    1466 PUSHACC5 
+    1467 GETFIELD0 
+    1468 PUSHACC5 
+    1469 PUSHACC5 
+    1470 APPLY3 
+    1471 PUSHACC3 
+    1472 PUSHOFFSETCLOSURE0 
+    1473 APPTERM 4, 8
+    1476 ACC3 
+    1477 BRANCHIF 1482
+    1479 ACC1 
+    1480 RETURN 4
+    1482 GETGLOBAL "List.fold_left2"
+    1484 PUSHGETGLOBALFIELD Pervasives, 2
+    1487 APPTERM1 5
+    1489 RESTART 
+    1490 GRAB 3
+    1492 ACC1 
+    1493 BRANCHIFNOT 1516
+    1495 ACC2 
+    1496 BRANCHIFNOT 1522
+    1498 PUSH_RETADDR 1509
+    1500 ACC6 
+    1501 PUSHACC6 
+    1502 GETFIELD1 
+    1503 PUSHACC6 
+    1504 GETFIELD1 
+    1505 PUSHACC6 
+    1506 PUSHOFFSETCLOSURE0 
+    1507 APPLY 4
+    1509 PUSHACC3 
+    1510 GETFIELD0 
+    1511 PUSHACC3 
+    1512 GETFIELD0 
+    1513 PUSHACC3 
+    1514 APPTERM3 7
+    1516 ACC2 
+    1517 BRANCHIF 1522
+    1519 ACC3 
+    1520 RETURN 4
+    1522 GETGLOBAL "List.fold_right2"
+    1524 PUSHGETGLOBALFIELD Pervasives, 2
+    1527 APPTERM1 5
+    1529 RESTART 
+    1530 GRAB 1
+    1532 ACC1 
+    1533 BRANCHIFNOT 1549
+    1535 ACC1 
+    1536 GETFIELD0 
+    1537 PUSHACC1 
+    1538 APPLY1 
+    1539 BRANCHIFNOT 1547
+    1541 ACC1 
+    1542 GETFIELD1 
+    1543 PUSHACC1 
+    1544 PUSHOFFSETCLOSURE0 
+    1545 APPTERM2 4
+    1547 RETURN 2
+    1549 CONST1 
+    1550 RETURN 2
+    1552 RESTART 
+    1553 GRAB 1
+    1555 ACC1 
+    1556 BRANCHIFNOT 1570
+    1558 ACC1 
+    1559 GETFIELD0 
+    1560 PUSHACC1 
+    1561 APPLY1 
+    1562 BRANCHIF 1570
+    1564 ACC1 
+    1565 GETFIELD1 
+    1566 PUSHACC1 
+    1567 PUSHOFFSETCLOSURE0 
+    1568 APPTERM2 4
+    1570 RETURN 2
+    1572 RESTART 
+    1573 GRAB 2
+    1575 ACC1 
+    1576 BRANCHIFNOT 1599
+    1578 ACC2 
+    1579 BRANCHIFNOT 1605
+    1581 ACC2 
+    1582 GETFIELD0 
+    1583 PUSHACC2 
+    1584 GETFIELD0 
+    1585 PUSHACC2 
+    1586 APPLY2 
+    1587 BRANCHIFNOT 1597
+    1589 ACC2 
+    1590 GETFIELD1 
+    1591 PUSHACC2 
+    1592 GETFIELD1 
+    1593 PUSHACC2 
+    1594 PUSHOFFSETCLOSURE0 
+    1595 APPTERM3 6
+    1597 RETURN 3
+    1599 ACC2 
+    1600 BRANCHIF 1605
+    1602 CONST1 
+    1603 RETURN 3
+    1605 GETGLOBAL "List.for_all2"
+    1607 PUSHGETGLOBALFIELD Pervasives, 2
+    1610 APPTERM1 4
+    1612 RESTART 
+    1613 GRAB 2
+    1615 ACC1 
+    1616 BRANCHIFNOT 1639
+    1618 ACC2 
+    1619 BRANCHIFNOT 1646
+    1621 ACC2 
+    1622 GETFIELD0 
+    1623 PUSHACC2 
+    1624 GETFIELD0 
+    1625 PUSHACC2 
+    1626 APPLY2 
+    1627 BRANCHIF 1637
+    1629 ACC2 
+    1630 GETFIELD1 
+    1631 PUSHACC2 
+    1632 GETFIELD1 
+    1633 PUSHACC2 
+    1634 PUSHOFFSETCLOSURE0 
+    1635 APPTERM3 6
+    1637 RETURN 3
+    1639 ACC2 
+    1640 BRANCHIFNOT 1644
+    1642 BRANCH 1646
+    1644 RETURN 3
+    1646 GETGLOBAL "List.exists2"
+    1648 PUSHGETGLOBALFIELD Pervasives, 2
+    1651 APPTERM1 4
+    1653 RESTART 
+    1654 GRAB 1
+    1656 ACC1 
+    1657 BRANCHIFNOT 1672
+    1659 ACC0 
+    1660 PUSHACC2 
+    1661 GETFIELD0 
+    1662 C_CALL2 equal
+    1664 BRANCHIF 1672
+    1666 ACC1 
+    1667 GETFIELD1 
+    1668 PUSHACC1 
+    1669 PUSHOFFSETCLOSURE0 
+    1670 APPTERM2 4
+    1672 RETURN 2
+    1674 RESTART 
+    1675 GRAB 1
+    1677 ACC1 
+    1678 BRANCHIFNOT 1692
+    1680 ACC0 
+    1681 PUSHACC2 
+    1682 GETFIELD0 
+    1683 EQ 
+    1684 BRANCHIF 1692
+    1686 ACC1 
+    1687 GETFIELD1 
+    1688 PUSHACC1 
+    1689 PUSHOFFSETCLOSURE0 
+    1690 APPTERM2 4
+    1692 RETURN 2
+    1694 RESTART 
+    1695 GRAB 1
+    1697 ACC1 
+    1698 BRANCHIFNOT 1719
+    1700 ACC1 
+    1701 GETFIELD0 
+    1702 PUSHACC1 
+    1703 PUSHACC1 
+    1704 GETFIELD0 
+    1705 C_CALL2 equal
+    1707 BRANCHIFNOT 1713
+    1709 ACC0 
+    1710 GETFIELD1 
+    1711 RETURN 3
+    1713 ACC2 
+    1714 GETFIELD1 
+    1715 PUSHACC2 
+    1716 PUSHOFFSETCLOSURE0 
+    1717 APPTERM2 5
+    1719 GETGLOBAL Not_found
+    1721 MAKEBLOCK1 0
+    1723 RAISE 
+    1724 RESTART 
+    1725 GRAB 1
+    1727 ACC1 
+    1728 BRANCHIFNOT 1748
+    1730 ACC1 
+    1731 GETFIELD0 
+    1732 PUSHACC1 
+    1733 PUSHACC1 
+    1734 GETFIELD0 
+    1735 EQ 
+    1736 BRANCHIFNOT 1742
+    1738 ACC0 
+    1739 GETFIELD1 
+    1740 RETURN 3
+    1742 ACC2 
+    1743 GETFIELD1 
+    1744 PUSHACC2 
+    1745 PUSHOFFSETCLOSURE0 
+    1746 APPTERM2 5
+    1748 GETGLOBAL Not_found
+    1750 MAKEBLOCK1 0
+    1752 RAISE 
+    1753 RESTART 
+    1754 GRAB 1
+    1756 ACC1 
+    1757 BRANCHIFNOT 1773
+    1759 ACC0 
+    1760 PUSHACC2 
+    1761 GETFIELD0 
+    1762 GETFIELD0 
+    1763 C_CALL2 equal
+    1765 BRANCHIF 1773
+    1767 ACC1 
+    1768 GETFIELD1 
+    1769 PUSHACC1 
+    1770 PUSHOFFSETCLOSURE0 
+    1771 APPTERM2 4
+    1773 RETURN 2
+    1775 RESTART 
+    1776 GRAB 1
+    1778 ACC1 
+    1779 BRANCHIFNOT 1794
+    1781 ACC0 
+    1782 PUSHACC2 
+    1783 GETFIELD0 
+    1784 GETFIELD0 
+    1785 EQ 
+    1786 BRANCHIF 1794
+    1788 ACC1 
+    1789 GETFIELD1 
+    1790 PUSHACC1 
+    1791 PUSHOFFSETCLOSURE0 
+    1792 APPTERM2 4
+    1794 RETURN 2
+    1796 RESTART 
+    1797 GRAB 1
+    1799 ACC1 
+    1800 BRANCHIFNOT 1825
+    1802 ACC1 
+    1803 GETFIELD0 
+    1804 PUSHACC2 
+    1805 GETFIELD1 
+    1806 PUSHACC2 
+    1807 PUSHACC2 
+    1808 GETFIELD0 
+    1809 C_CALL2 equal
+    1811 BRANCHIFNOT 1816
+    1813 ACC0 
+    1814 RETURN 4
+    1816 ACC0 
+    1817 PUSHACC3 
+    1818 PUSHOFFSETCLOSURE0 
+    1819 APPLY2 
+    1820 PUSHACC2 
+    1821 MAKEBLOCK2 0
+    1823 POP 2
+    1825 RETURN 2
+    1827 RESTART 
+    1828 GRAB 1
+    1830 ACC1 
+    1831 BRANCHIFNOT 1855
+    1833 ACC1 
+    1834 GETFIELD0 
+    1835 PUSHACC2 
+    1836 GETFIELD1 
+    1837 PUSHACC2 
+    1838 PUSHACC2 
+    1839 GETFIELD0 
+    1840 EQ 
+    1841 BRANCHIFNOT 1846
+    1843 ACC0 
+    1844 RETURN 4
+    1846 ACC0 
+    1847 PUSHACC3 
+    1848 PUSHOFFSETCLOSURE0 
+    1849 APPLY2 
+    1850 PUSHACC2 
+    1851 MAKEBLOCK2 0
+    1853 POP 2
+    1855 RETURN 2
+    1857 RESTART 
+    1858 GRAB 1
+    1860 ACC1 
+    1861 BRANCHIFNOT 1879
+    1863 ACC1 
+    1864 GETFIELD0 
+    1865 PUSHACC0 
+    1866 PUSHACC2 
+    1867 APPLY1 
+    1868 BRANCHIFNOT 1873
+    1870 ACC0 
+    1871 RETURN 3
+    1873 ACC2 
+    1874 GETFIELD1 
+    1875 PUSHACC2 
+    1876 PUSHOFFSETCLOSURE0 
+    1877 APPTERM2 5
+    1879 GETGLOBAL Not_found
+    1881 MAKEBLOCK1 0
+    1883 RAISE 
+    1884 RESTART 
+    1885 GRAB 2
+    1887 ACC2 
+    1888 BRANCHIFNOT 1917
+    1890 ACC2 
+    1891 GETFIELD0 
+    1892 PUSHACC3 
+    1893 GETFIELD1 
+    1894 PUSHACC1 
+    1895 PUSHENVACC2 
+    1896 APPLY1 
+    1897 BRANCHIFNOT 1908
+    1899 ACC0 
+    1900 PUSHACC4 
+    1901 PUSHACC4 
+    1902 PUSHACC4 
+    1903 MAKEBLOCK2 0
+    1905 PUSHOFFSETCLOSURE0 
+    1906 APPTERM3 8
+    1908 ACC0 
+    1909 PUSHACC4 
+    1910 PUSHACC3 
+    1911 MAKEBLOCK2 0
+    1913 PUSHACC4 
+    1914 PUSHOFFSETCLOSURE0 
+    1915 APPTERM3 8
+    1917 ACC1 
+    1918 PUSHENVACC1 
+    1919 APPLY1 
+    1920 PUSHACC1 
+    1921 PUSHENVACC1 
+    1922 APPLY1 
+    1923 MAKEBLOCK2 0
+    1925 RETURN 3
+    1927 RESTART 
+    1928 GRAB 1
+    1930 ACC0 
+    1931 PUSHENVACC1 
+    1932 CLOSUREREC 2, 1885
+    1936 ACC2 
+    1937 PUSHCONST0 
+    1938 PUSHCONST0 
+    1939 PUSHACC3 
+    1940 APPTERM3 6
+    1942 ACC0 
+    1943 BRANCHIFNOT 1967
+    1945 ACC0 
+    1946 GETFIELD0 
+    1947 PUSHACC1 
+    1948 GETFIELD1 
+    1949 PUSHOFFSETCLOSURE0 
+    1950 APPLY1 
+    1951 PUSHACC0 
+    1952 GETFIELD1 
+    1953 PUSHACC2 
+    1954 GETFIELD1 
+    1955 MAKEBLOCK2 0
+    1957 PUSHACC1 
+    1958 GETFIELD0 
+    1959 PUSHACC3 
+    1960 GETFIELD0 
+    1961 MAKEBLOCK2 0
+    1963 MAKEBLOCK2 0
+    1965 RETURN 3
+    1967 GETGLOBAL <0>(0, 0)
+    1969 RETURN 1
+    1971 RESTART 
+    1972 GRAB 1
+    1974 ACC0 
+    1975 BRANCHIFNOT 1996
+    1977 ACC1 
+    1978 BRANCHIFNOT 2003
+    1980 ACC1 
+    1981 GETFIELD1 
+    1982 PUSHACC1 
+    1983 GETFIELD1 
+    1984 PUSHOFFSETCLOSURE0 
+    1985 APPLY2 
+    1986 PUSHACC2 
+    1987 GETFIELD0 
+    1988 PUSHACC2 
+    1989 GETFIELD0 
+    1990 MAKEBLOCK2 0
+    1992 MAKEBLOCK2 0
+    1994 RETURN 2
+    1996 ACC1 
+    1997 BRANCHIFNOT 2001
+    1999 BRANCH 2003
+    2001 RETURN 2
+    2003 GETGLOBAL "List.combine"
+    2005 PUSHGETGLOBALFIELD Pervasives, 2
+    2008 APPTERM1 3
+    2010 RESTART 
+    2011 GRAB 1
+    2013 ACC1 
+    2014 BRANCHIFNOT 2038
+    2016 ACC1 
+    2017 GETFIELD0 
+    2018 PUSHACC2 
+    2019 GETFIELD1 
+    2020 PUSHACC1 
+    2021 PUSHENVACC2 
+    2022 APPLY1 
+    2023 BRANCHIFNOT 2033
+    2025 ACC0 
+    2026 PUSHACC3 
+    2027 PUSHACC3 
+    2028 MAKEBLOCK2 0
+    2030 PUSHOFFSETCLOSURE0 
+    2031 APPTERM2 6
+    2033 ACC0 
+    2034 PUSHACC3 
+    2035 PUSHOFFSETCLOSURE0 
+    2036 APPTERM2 6
+    2038 ACC0 
+    2039 PUSHENVACC1 
+    2040 APPTERM1 3
+    2042 ACC0 
+    2043 PUSHENVACC1 
+    2044 CLOSUREREC 2, 2011
+    2048 CONST0 
+    2049 PUSHACC1 
+    2050 APPTERM1 3
+    2052 RESTART 
+    2053 GRAB 2
+    2055 ACC1 
+    2056 BRANCHIFNOT 2077
+    2058 ACC2 
+    2059 BRANCHIFNOT 2084
+    2061 ACC2 
+    2062 GETFIELD1 
+    2063 PUSHACC2 
+    2064 GETFIELD1 
+    2065 PUSHACC2 
+    2066 PUSHACC5 
+    2067 GETFIELD0 
+    2068 PUSHACC5 
+    2069 GETFIELD0 
+    2070 PUSHENVACC1 
+    2071 APPLY2 
+    2072 MAKEBLOCK2 0
+    2074 PUSHOFFSETCLOSURE0 
+    2075 APPTERM3 6
+    2077 ACC2 
+    2078 BRANCHIFNOT 2082
+    2080 BRANCH 2084
+    2082 RETURN 3
+    2084 GETGLOBAL "List.rev_map2"
+    2086 PUSHGETGLOBALFIELD Pervasives, 2
+    2089 APPTERM1 4
+    2091 RESTART 
+    2092 GRAB 2
+    2094 ACC0 
+    2095 CLOSUREREC 1, 2053
+    2099 ACC3 
+    2100 PUSHACC3 
+    2101 PUSHCONST0 
+    2102 PUSHACC3 
+    2103 APPTERM3 7
+    2105 RESTART 
+    2106 GRAB 1
+    2108 ACC1 
+    2109 BRANCHIFNOT 2123
+    2111 ACC1 
+    2112 GETFIELD1 
+    2113 PUSHACC1 
+    2114 PUSHACC3 
+    2115 GETFIELD0 
+    2116 PUSHENVACC1 
+    2117 APPLY1 
+    2118 MAKEBLOCK2 0
+    2120 PUSHOFFSETCLOSURE0 
+    2121 APPTERM2 4
+    2123 ACC0 
+    2124 RETURN 2
+    2126 RESTART 
+    2127 GRAB 1
+    2129 ACC0 
+    2130 CLOSUREREC 1, 2106
+    2134 ACC2 
+    2135 PUSHCONST0 
+    2136 PUSHACC2 
+    2137 APPTERM2 5
+    2139 CONST0 
+    2140 PUSHACC1 
+    2141 PUSHENVACC1 
+    2142 APPTERM2 3
+    2144 ACC0 
+    2145 BRANCHIFNOT 2151
+    2147 ACC0 
+    2148 GETFIELD1 
+    2149 RETURN 1
+    2151 GETGLOBAL "tl"
+    2153 PUSHGETGLOBALFIELD Pervasives, 3
+    2156 APPTERM1 2
+    2158 ACC0 
+    2159 BRANCHIFNOT 2165
+    2161 ACC0 
+    2162 GETFIELD0 
+    2163 RETURN 1
+    2165 GETGLOBAL "hd"
+    2167 PUSHGETGLOBALFIELD Pervasives, 3
+    2170 APPTERM1 2
+    2172 ACC0 
+    2173 PUSHCONST0 
+    2174 PUSHENVACC1 
+    2175 APPTERM2 3
+    2177 CLOSUREREC 0, 1200
+    2181 ACC0 
+    2182 CLOSURE 1, 2172
+    2185 PUSH 
+    2186 CLOSURE 0, 2158
+    2189 PUSH 
+    2190 CLOSURE 0, 2144
+    2193 PUSH 
+    2194 CLOSUREREC 0, 1217
+    2198 GETGLOBALFIELD Pervasives, 16
+    2201 PUSH 
+    2202 CLOSUREREC 0, 1259
+    2206 ACC0 
+    2207 CLOSURE 1, 2139
+    2210 PUSH 
+    2211 CLOSUREREC 0, 1277
+    2215 CLOSUREREC 0, 1294
+    2219 CLOSURE 0, 2127
+    2222 PUSH 
+    2223 CLOSUREREC 0, 1316
+    2227 CLOSUREREC 0, 1334
+    2231 CLOSUREREC 0, 1354
+    2235 CLOSUREREC 0, 1374
+    2239 CLOSURE 0, 2092
+    2242 PUSH 
+    2243 CLOSUREREC 0, 1415
+    2247 CLOSUREREC 0, 1452
+    2251 CLOSUREREC 0, 1490
+    2255 CLOSUREREC 0, 1530
+    2259 CLOSUREREC 0, 1553
+    2263 CLOSUREREC 0, 1573
+    2267 CLOSUREREC 0, 1613
+    2271 CLOSUREREC 0, 1654
+    2275 CLOSUREREC 0, 1675
+    2279 CLOSUREREC 0, 1695
+    2283 CLOSUREREC 0, 1725
+    2287 CLOSUREREC 0, 1754
+    2291 CLOSUREREC 0, 1776
+    2295 CLOSUREREC 0, 1797
+    2299 CLOSUREREC 0, 1828
+    2303 CLOSUREREC 0, 1858
+    2307 ACC 24
+    2309 CLOSURE 1, 2042
+    2312 PUSHACC 25
+    2314 CLOSUREREC 1, 1928
+    2318 CLOSUREREC 0, 1942
+    2322 CLOSUREREC 0, 1972
+    2326 ACC0 
+    2327 PUSHACC2 
+    2328 PUSHACC7 
+    2329 PUSHACC 9
+    2331 PUSHACC 11
+    2333 PUSHACC 13
+    2335 PUSHACC 15
+    2337 PUSHACC 17
+    2339 PUSHACC 10
+    2341 PUSHACC 12
+    2343 PUSHACC 13
+    2345 PUSHACC 15
+    2347 PUSHACC 23
+    2349 PUSHACC 25
+    2351 PUSHACC 27
+    2353 PUSHACC 29
+    2355 PUSHACC 31
+    2357 PUSHACC 33
+    2359 PUSHACC 35
+    2361 PUSHACC 37
+    2363 PUSHACC 40
+    2365 PUSHACC 42
+    2367 PUSHACC 41
+    2369 PUSHACC 45
+    2371 PUSHACC 47
+    2373 PUSHACC 50
+    2375 PUSHACC 52
+    2377 PUSHACC 51
+    2379 PUSHACC 55
+    2381 PUSHACC 56
+    2383 PUSHACC 59
+    2385 PUSHACC 61
+    2387 PUSHACC 60
+    2389 PUSHACC 64
+    2391 PUSHACC 66
+    2393 PUSHACC 68
+    2395 PUSHACC 70
+    2397 MAKEBLOCK 37, 0
+    2400 POP 36
+    2402 SETGLOBAL List
+    2404 BRANCH 2622
+    2406 CONSTINT 97
+    2408 PUSHACC1 
+    2409 GEINT 
+    2410 BRANCHIFNOT 2418
+    2412 CONSTINT 122
+    2414 PUSHACC1 
+    2415 LEINT 
+    2416 BRANCHIF 2442
+    2418 CONSTINT 224
+    2420 PUSHACC1 
+    2421 GEINT 
+    2422 BRANCHIFNOT 2430
+    2424 CONSTINT 246
+    2426 PUSHACC1 
+    2427 LEINT 
+    2428 BRANCHIF 2442
+    2430 CONSTINT 248
+    2432 PUSHACC1 
+    2433 GEINT 
+    2434 BRANCHIFNOT 2447
+    2436 CONSTINT 254
+    2438 PUSHACC1 
+    2439 LEINT 
+    2440 BRANCHIFNOT 2447
+    2442 ACC0 
+    2443 OFFSETINT -32
+    2445 RETURN 1
+    2447 ACC0 
+    2448 RETURN 1
+    2450 CONSTINT 65
+    2452 PUSHACC1 
+    2453 GEINT 
+    2454 BRANCHIFNOT 2462
+    2456 CONSTINT 90
+    2458 PUSHACC1 
+    2459 LEINT 
+    2460 BRANCHIF 2486
+    2462 CONSTINT 192
+    2464 PUSHACC1 
+    2465 GEINT 
+    2466 BRANCHIFNOT 2474
+    2468 CONSTINT 214
+    2470 PUSHACC1 
+    2471 LEINT 
+    2472 BRANCHIF 2486
+    2474 CONSTINT 216
+    2476 PUSHACC1 
+    2477 GEINT 
+    2478 BRANCHIFNOT 2491
+    2480 CONSTINT 222
+    2482 PUSHACC1 
+    2483 LEINT 
+    2484 BRANCHIFNOT 2491
+    2486 ACC0 
+    2487 OFFSETINT 32
+    2489 RETURN 1
+    2491 ACC0 
+    2492 RETURN 1
+    2494 CONSTINT 39
+    2496 PUSHACC1 
+    2497 LTINT 
+    2498 BRANCHIFNOT 2520
+    2500 CONSTINT 9
+    2502 PUSHACC1 
+    2503 EQ 
+    2504 BRANCHIFNOT 2510
+    2506 GETGLOBAL "\\t"
+    2508 RETURN 1
+    2510 CONSTINT 13
+    2512 PUSHACC1 
+    2513 EQ 
+    2514 BRANCHIFNOT 2540
+    2516 GETGLOBAL "\\n"
+    2518 RETURN 1
+    2520 CONSTINT 39
+    2522 PUSHACC1 
+    2523 EQ 
+    2524 BRANCHIFNOT 2530
+    2526 GETGLOBAL "\\'"
+    2528 RETURN 1
+    2530 CONSTINT 92
+    2532 PUSHACC1 
+    2533 EQ 
+    2534 BRANCHIFNOT 2540
+    2536 GETGLOBAL "\\\\"
+    2538 RETURN 1
+    2540 ACC0 
+    2541 C_CALL1 is_printable
+    2543 BRANCHIFNOT 2555
+    2545 CONST1 
+    2546 C_CALL1 create_string
+    2548 PUSHACC1 
+    2549 PUSHCONST0 
+    2550 PUSHACC2 
+    2551 SETSTRINGCHAR 
+    2552 ACC0 
+    2553 RETURN 2
+    2555 ACC0 
+    2556 PUSHCONSTINT 4
+    2558 C_CALL1 create_string
+    2560 PUSHCONSTINT 92
+    2562 PUSHCONST0 
+    2563 PUSHACC2 
+    2564 SETSTRINGCHAR 
+    2565 CONSTINT 100
+    2567 PUSHACC2 
+    2568 DIVINT 
+    2569 PUSHCONSTINT 48
+    2571 ADDINT 
+    2572 PUSHCONST1 
+    2573 PUSHACC2 
+    2574 SETSTRINGCHAR 
+    2575 CONSTINT 10
+    2577 PUSHCONSTINT 10
+    2579 PUSHACC3 
+    2580 DIVINT 
+    2581 MODINT 
+    2582 PUSHCONSTINT 48
+    2584 ADDINT 
+    2585 PUSHCONST2 
+    2586 PUSHACC2 
+    2587 SETSTRINGCHAR 
+    2588 CONSTINT 10
+    2590 PUSHACC2 
+    2591 MODINT 
+    2592 PUSHCONSTINT 48
+    2594 ADDINT 
+    2595 PUSHCONST3 
+    2596 PUSHACC2 
+    2597 SETSTRINGCHAR 
+    2598 ACC0 
+    2599 RETURN 3
+    2601 CONST0 
+    2602 PUSHACC1 
+    2603 LTINT 
+    2604 BRANCHIF 2612
+    2606 CONSTINT 255
+    2608 PUSHACC1 
+    2609 GTINT 
+    2610 BRANCHIFNOT 2619
+    2612 GETGLOBAL "Char.chr"
+    2614 PUSHGETGLOBALFIELD Pervasives, 2
+    2617 APPTERM1 2
+    2619 ACC0 
+    2620 RETURN 1
+    2622 CLOSURE 0, 2601
+    2625 PUSH 
+    2626 CLOSURE 0, 2494
+    2629 PUSH 
+    2630 CLOSURE 0, 2450
+    2633 PUSH 
+    2634 CLOSURE 0, 2406
+    2637 PUSHACC0 
+    2638 PUSHACC2 
+    2639 PUSHACC4 
+    2640 PUSHACC6 
+    2641 MAKEBLOCK 4, 0
+    2644 POP 4
+    2646 SETGLOBAL Char
+    2648 BRANCH 3540
+    2650 RESTART 
+    2651 GRAB 3
+    2653 ACC1 
+    2654 PUSHACC3 
+    2655 GEINT 
+    2656 BRANCHIFNOT 2663
+    2658 GETGLOBAL Not_found
+    2660 MAKEBLOCK1 0
+    2662 RAISE 
+    2663 ACC3 
+    2664 PUSHACC3 
+    2665 PUSHACC2 
+    2666 GETSTRINGCHAR 
+    2667 EQ 
+    2668 BRANCHIFNOT 2673
+    2670 ACC2 
+    2671 RETURN 4
+    2673 ACC3 
+    2674 PUSHACC3 
+    2675 OFFSETINT 1
+    2677 PUSHACC3 
+    2678 PUSHACC3 
+    2679 PUSHOFFSETCLOSURE0 
+    2680 APPTERM 4, 8
+    2683 RESTART 
+    2684 GRAB 2
+    2686 CONST0 
+    2687 PUSHACC2 
+    2688 LTINT 
+    2689 BRANCHIFNOT 2696
+    2691 GETGLOBAL Not_found
+    2693 MAKEBLOCK1 0
+    2695 RAISE 
+    2696 ACC2 
+    2697 PUSHACC2 
+    2698 PUSHACC2 
+    2699 GETSTRINGCHAR 
+    2700 EQ 
+    2701 BRANCHIFNOT 2706
+    2703 ACC1 
+    2704 RETURN 3
+    2706 ACC2 
+    2707 PUSHACC2 
+    2708 OFFSETINT -1
+    2710 PUSHACC2 
+    2711 PUSHOFFSETCLOSURE0 
+    2712 APPTERM3 6
+    2714 RESTART 
+    2715 GRAB 1
+    2717 ACC1 
+    2718 PUSHCONST0 
+    2719 PUSHACC2 
+    2720 PUSHENVACC1 
+    2721 APPTERM3 5
+    2723 RESTART 
+    2724 GRAB 2
+    2726 CONST0 
+    2727 PUSHACC2 
+    2728 LTINT 
+    2729 BRANCHIF 2738
+    2731 ACC0 
+    2732 C_CALL1 ml_string_length
+    2734 PUSHACC2 
+    2735 GEINT 
+    2736 BRANCHIFNOT 2745
+    2738 GETGLOBAL "String.rcontains_from"
+    2740 PUSHGETGLOBALFIELD Pervasives, 2
+    2743 APPTERM1 4
+    2745 PUSHTRAP 2756
+    2747 ACC6 
+    2748 PUSHACC6 
+    2749 PUSHACC6 
+    2750 PUSHENVACC1 
+    2751 APPLY3 
+    2752 CONST1 
+    2753 POPTRAP 
+    2754 RETURN 3
+    2756 PUSHGETGLOBAL Not_found
+    2758 PUSHACC1 
+    2759 GETFIELD0 
+    2760 EQ 
+    2761 BRANCHIFNOT 2766
+    2763 CONST0 
+    2764 RETURN 4
+    2766 ACC0 
+    2767 RAISE 
+    2768 RESTART 
+    2769 GRAB 2
+    2771 CONST0 
+    2772 PUSHACC2 
+    2773 LTINT 
+    2774 BRANCHIF 2783
+    2776 ACC0 
+    2777 C_CALL1 ml_string_length
+    2779 PUSHACC2 
+    2780 GTINT 
+    2781 BRANCHIFNOT 2790
+    2783 GETGLOBAL "String.contains_from"
+    2785 PUSHGETGLOBALFIELD Pervasives, 2
+    2788 APPTERM1 4
+    2790 PUSHTRAP 2811
+    2792 PUSH_RETADDR 2807
+    2794 ACC 9
+    2796 PUSHACC 9
+    2798 PUSHACC 9
+    2800 C_CALL1 ml_string_length
+    2802 PUSHACC 10
+    2804 PUSHENVACC1 
+    2805 APPLY 4
+    2807 CONST1 
+    2808 POPTRAP 
+    2809 RETURN 3
+    2811 PUSHGETGLOBAL Not_found
+    2813 PUSHACC1 
+    2814 GETFIELD0 
+    2815 EQ 
+    2816 BRANCHIFNOT 2821
+    2818 CONST0 
+    2819 RETURN 4
+    2821 ACC0 
+    2822 RAISE 
+    2823 RESTART 
+    2824 GRAB 2
+    2826 CONST0 
+    2827 PUSHACC2 
+    2828 LTINT 
+    2829 BRANCHIF 2838
+    2831 ACC0 
+    2832 C_CALL1 ml_string_length
+    2834 PUSHACC2 
+    2835 GEINT 
+    2836 BRANCHIFNOT 2845
+    2838 GETGLOBAL "String.rindex_from"
+    2840 PUSHGETGLOBALFIELD Pervasives, 2
+    2843 APPTERM1 4
+    2845 ACC2 
+    2846 PUSHACC2 
+    2847 PUSHACC2 
+    2848 PUSHENVACC1 
+    2849 APPTERM3 6
+    2851 RESTART 
+    2852 GRAB 1
+    2854 ACC1 
+    2855 PUSHACC1 
+    2856 C_CALL1 ml_string_length
+    2858 OFFSETINT -1
+    2860 PUSHACC2 
+    2861 PUSHENVACC1 
+    2862 APPTERM3 5
+    2864 RESTART 
+    2865 GRAB 2
+    2867 CONST0 
+    2868 PUSHACC2 
+    2869 LTINT 
+    2870 BRANCHIF 2879
+    2872 ACC0 
+    2873 C_CALL1 ml_string_length
+    2875 PUSHACC2 
+    2876 GTINT 
+    2877 BRANCHIFNOT 2886
+    2879 GETGLOBAL "String.index_from"
+    2881 PUSHGETGLOBALFIELD Pervasives, 2
+    2884 APPTERM1 4
+    2886 ACC2 
+    2887 PUSHACC2 
+    2888 PUSHACC2 
+    2889 C_CALL1 ml_string_length
+    2891 PUSHACC3 
+    2892 PUSHENVACC1 
+    2893 APPTERM 4, 7
+    2896 RESTART 
+    2897 GRAB 1
+    2899 ACC1 
+    2900 PUSHCONST0 
+    2901 PUSHACC2 
+    2902 C_CALL1 ml_string_length
+    2904 PUSHACC3 
+    2905 PUSHENVACC1 
+    2906 APPTERM 4, 6
+    2909 ACC0 
+    2910 PUSHGETGLOBALFIELD Char, 2
+    2913 PUSHENVACC1 
+    2914 APPTERM2 3
+    2916 ACC0 
+    2917 PUSHGETGLOBALFIELD Char, 3
+    2920 PUSHENVACC1 
+    2921 APPTERM2 3
+    2923 RESTART 
+    2924 GRAB 1
+    2926 CONST0 
+    2927 PUSHACC2 
+    2928 C_CALL1 ml_string_length
+    2930 EQ 
+    2931 BRANCHIFNOT 2936
+    2933 ACC1 
+    2934 RETURN 2
+    2936 ACC1 
+    2937 PUSHENVACC1 
+    2938 APPLY1 
+    2939 PUSHCONST0 
+    2940 PUSHACC3 
+    2941 GETSTRINGCHAR 
+    2942 PUSHACC2 
+    2943 APPLY1 
+    2944 PUSHCONST0 
+    2945 PUSHACC2 
+    2946 SETSTRINGCHAR 
+    2947 ACC0 
+    2948 RETURN 3
+    2950 ACC0 
+    2951 PUSHGETGLOBALFIELD Char, 2
+    2954 PUSHENVACC1 
+    2955 APPTERM2 3
+    2957 ACC0 
+    2958 PUSHGETGLOBALFIELD Char, 3
+    2961 PUSHENVACC1 
+    2962 APPTERM2 3
+    2964 RESTART 
+    2965 GRAB 1
+    2967 ACC1 
+    2968 C_CALL1 ml_string_length
+    2970 PUSHCONST0 
+    2971 PUSHACC1 
+    2972 EQ 
+    2973 BRANCHIFNOT 2978
+    2975 ACC2 
+    2976 RETURN 3
+    2978 ACC0 
+    2979 C_CALL1 create_string
+    2981 PUSHCONST0 
+    2982 PUSHACC2 
+    2983 OFFSETINT -1
+    2985 PUSH 
+    2986 BRANCH 3002
+    2988 CHECK_SIGNALS 
+    2989 ACC1 
+    2990 PUSHACC6 
+    2991 GETSTRINGCHAR 
+    2992 PUSHACC5 
+    2993 APPLY1 
+    2994 PUSHACC2 
+    2995 PUSHACC4 
+    2996 SETSTRINGCHAR 
+    2997 ACC1 
+    2998 OFFSETINT 1
+    3000 ASSIGN 1
+    3002 ACC0 
+    3003 PUSHACC2 
+    3004 LEINT 
+    3005 BRANCHIF 2988
+    3007 CONST0 
+    3008 POP 2
+    3010 ACC0 
+    3011 RETURN 4
+    3013 CONST0 
+    3014 PUSHCONST0 
+    3015 PUSHACC2 
+    3016 C_CALL1 ml_string_length
+    3018 OFFSETINT -1
+    3020 PUSH 
+    3021 BRANCH 3059
+    3023 CHECK_SIGNALS 
+    3024 ACC1 
+    3025 PUSHACC4 
+    3026 GETSTRINGCHAR 
+    3027 PUSHACC0 
+    3028 PUSHGETGLOBAL "\000\"\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
+    3030 C_CALL2 bitvect_test
+    3032 BRANCHIFNOT 3038
+    3034 CONST0 
+    3035 CONST2 
+    3036 BRANCH 3048
+    3038 ACC0 
+    3039 C_CALL1 is_printable
+    3041 BRANCHIFNOT 3046
+    3043 CONST1 
+    3044 BRANCH 3048
+    3046 CONSTINT 4
+    3048 POP 1
+    3050 PUSHACC3 
+    3051 ADDINT 
+    3052 ASSIGN 2
+    3054 ACC1 
+    3055 OFFSETINT 1
+    3057 ASSIGN 1
+    3059 ACC0 
+    3060 PUSHACC2 
+    3061 LEINT 
+    3062 BRANCHIF 3023
+    3064 CONST0 
+    3065 POP 2
+    3067 ACC1 
+    3068 C_CALL1 ml_string_length
+    3070 PUSHACC1 
+    3071 EQ 
+    3072 BRANCHIFNOT 3077
+    3074 ACC1 
+    3075 RETURN 2
+    3077 ACC0 
+    3078 C_CALL1 create_string
+    3080 PUSHCONST0 
+    3081 ASSIGN 1
+    3083 CONST0 
+    3084 PUSHACC3 
+    3085 C_CALL1 ml_string_length
+    3087 OFFSETINT -1
+    3089 PUSH 
+    3090 BRANCH 3245
+    3092 CHECK_SIGNALS 
+    3093 ACC1 
+    3094 PUSHACC5 
+    3095 GETSTRINGCHAR 
+    3096 PUSHACC0 
+    3097 PUSHGETGLOBAL "\000\000\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
+    3099 C_CALL2 bitvect_test
+    3101 BRANCHIFNOT 3120
+    3103 CONST0 
+    3104 CONSTINT 92
+    3106 PUSHACC5 
+    3107 PUSHACC5 
+    3108 SETSTRINGCHAR 
+    3109 ACC4 
+    3110 OFFSETINT 1
+    3112 ASSIGN 4
+    3114 ACC0 
+    3115 PUSHACC5 
+    3116 PUSHACC5 
+    3117 SETSTRINGCHAR 
+    3118 BRANCH 3233
+    3120 CONSTINT 9
+    3122 PUSHACC1 
+    3123 EQ 
+    3124 BRANCHIFNOT 3143
+    3126 CONSTINT 92
+    3128 PUSHACC5 
+    3129 PUSHACC5 
+    3130 SETSTRINGCHAR 
+    3131 ACC4 
+    3132 OFFSETINT 1
+    3134 ASSIGN 4
+    3136 CONSTINT 116
+    3138 PUSHACC5 
+    3139 PUSHACC5 
+    3140 SETSTRINGCHAR 
+    3141 BRANCH 3233
+    3143 CONSTINT 13
+    3145 PUSHACC1 
+    3146 EQ 
+    3147 BRANCHIFNOT 3166
+    3149 CONSTINT 92
+    3151 PUSHACC5 
+    3152 PUSHACC5 
+    3153 SETSTRINGCHAR 
+    3154 ACC4 
+    3155 OFFSETINT 1
+    3157 ASSIGN 4
+    3159 CONSTINT 110
+    3161 PUSHACC5 
+    3162 PUSHACC5 
+    3163 SETSTRINGCHAR 
+    3164 BRANCH 3233
+    3166 ACC0 
+    3167 C_CALL1 is_printable
+    3169 BRANCHIFNOT 3177
+    3171 ACC0 
+    3172 PUSHACC5 
+    3173 PUSHACC5 
+    3174 SETSTRINGCHAR 
+    3175 BRANCH 3233
+    3177 ACC0 
+    3178 PUSHCONSTINT 92
+    3180 PUSHACC6 
+    3181 PUSHACC6 
+    3182 SETSTRINGCHAR 
+    3183 ACC5 
+    3184 OFFSETINT 1
+    3186 ASSIGN 5
+    3188 CONSTINT 100
+    3190 PUSHACC1 
+    3191 DIVINT 
+    3192 PUSHCONSTINT 48
+    3194 ADDINT 
+    3195 PUSHACC6 
+    3196 PUSHACC6 
+    3197 SETSTRINGCHAR 
+    3198 ACC5 
+    3199 OFFSETINT 1
+    3201 ASSIGN 5
+    3203 CONSTINT 10
+    3205 PUSHCONSTINT 10
+    3207 PUSHACC2 
+    3208 DIVINT 
+    3209 MODINT 
+    3210 PUSHCONSTINT 48
+    3212 ADDINT 
+    3213 PUSHACC6 
+    3214 PUSHACC6 
+    3215 SETSTRINGCHAR 
+    3216 ACC5 
+    3217 OFFSETINT 1
+    3219 ASSIGN 5
+    3221 CONSTINT 10
+    3223 PUSHACC1 
+    3224 MODINT 
+    3225 PUSHCONSTINT 48
+    3227 ADDINT 
+    3228 PUSHACC6 
+    3229 PUSHACC6 
+    3230 SETSTRINGCHAR 
+    3231 POP 1
+    3233 POP 1
+    3235 ACC3 
+    3236 OFFSETINT 1
+    3238 ASSIGN 3
+    3240 ACC1 
+    3241 OFFSETINT 1
+    3243 ASSIGN 1
+    3245 ACC0 
+    3246 PUSHACC2 
+    3247 LEINT 
+    3248 BRANCHIF 3092
+    3250 CONST0 
+    3251 POP 2
+    3253 ACC0 
+    3254 RETURN 3
+    3256 ENVACC1 
+    3257 C_CALL1 ml_string_length
+    3259 PUSHENVACC3 
+    3260 GETFIELD0 
+    3261 PUSHENVACC2 
+    3262 PUSHCONST0 
+    3263 PUSHENVACC1 
+    3264 C_CALL5 blit_string
+    3266 ENVACC1 
+    3267 C_CALL1 ml_string_length
+    3269 PUSHENVACC3 
+    3270 GETFIELD0 
+    3271 ADDINT 
+    3272 PUSHENVACC3 
+    3273 SETFIELD0 
+    3274 ACC0 
+    3275 C_CALL1 ml_string_length
+    3277 PUSHENVACC3 
+    3278 GETFIELD0 
+    3279 PUSHENVACC2 
+    3280 PUSHCONST0 
+    3281 PUSHACC4 
+    3282 C_CALL5 blit_string
+    3284 ACC0 
+    3285 C_CALL1 ml_string_length
+    3287 PUSHENVACC3 
+    3288 GETFIELD0 
+    3289 ADDINT 
+    3290 PUSHENVACC3 
+    3291 SETFIELD0 
+    3292 RETURN 1
+    3294 ENVACC1 
+    3295 OFFSETREF 1
+    3297 ACC0 
+    3298 C_CALL1 ml_string_length
+    3300 PUSHENVACC2 
+    3301 GETFIELD0 
+    3302 ADDINT 
+    3303 PUSHENVACC2 
+    3304 SETFIELD0 
+    3305 RETURN 1
+    3307 RESTART 
+    3308 GRAB 1
+    3310 ACC1 
+    3311 BRANCHIFNOT 3374
+    3313 ACC1 
+    3314 GETFIELD0 
+    3315 PUSHCONST0 
+    3316 MAKEBLOCK1 0
+    3318 PUSHCONST0 
+    3319 MAKEBLOCK1 0
+    3321 PUSHACC4 
+    3322 PUSHACC1 
+    3323 PUSHACC3 
+    3324 CLOSURE 2, 3294
+    3327 PUSHGETGLOBALFIELD List, 9
+    3330 APPLY2 
+    3331 ACC1 
+    3332 GETFIELD0 
+    3333 OFFSETINT -1
+    3335 PUSHACC4 
+    3336 C_CALL1 ml_string_length
+    3338 MULINT 
+    3339 PUSHACC1 
+    3340 GETFIELD0 
+    3341 ADDINT 
+    3342 C_CALL1 create_string
+    3344 PUSHACC3 
+    3345 C_CALL1 ml_string_length
+    3347 PUSHCONST0 
+    3348 PUSHACC2 
+    3349 PUSHCONST0 
+    3350 PUSHACC7 
+    3351 C_CALL5 blit_string
+    3353 ACC3 
+    3354 C_CALL1 ml_string_length
+    3356 MAKEBLOCK1 0
+    3358 PUSHACC6 
+    3359 GETFIELD1 
+    3360 PUSHACC1 
+    3361 PUSHACC3 
+    3362 PUSHACC 8
+    3364 CLOSURE 3, 3256
+    3367 PUSHGETGLOBALFIELD List, 9
+    3370 APPLY2 
+    3371 ACC1 
+    3372 RETURN 7
+    3374 GETGLOBAL ""
+    3376 RETURN 2
+    3378 RESTART 
+    3379 GRAB 4
+    3381 CONST0 
+    3382 PUSHACC5 
+    3383 LTINT 
+    3384 BRANCHIF 3414
+    3386 CONST0 
+    3387 PUSHACC2 
+    3388 LTINT 
+    3389 BRANCHIF 3414
+    3391 ACC0 
+    3392 C_CALL1 ml_string_length
+    3394 PUSHACC5 
+    3395 PUSHACC3 
+    3396 ADDINT 
+    3397 GTINT 
+    3398 BRANCHIF 3414
+    3400 CONST0 
+    3401 PUSHACC4 
+    3402 LTINT 
+    3403 BRANCHIF 3414
+    3405 ACC2 
+    3406 C_CALL1 ml_string_length
+    3408 PUSHACC5 
+    3409 PUSHACC5 
+    3410 ADDINT 
+    3411 GTINT 
+    3412 BRANCHIFNOT 3421
+    3414 GETGLOBAL "String.blit"
+    3416 PUSHGETGLOBALFIELD Pervasives, 2
+    3419 APPTERM1 6
+    3421 ACC4 
+    3422 PUSHACC4 
+    3423 PUSHACC4 
+    3424 PUSHACC4 
+    3425 PUSHACC4 
+    3426 C_CALL5 blit_string
+    3428 RETURN 5
+    3430 RESTART 
+    3431 GRAB 3
+    3433 CONST0 
+    3434 PUSHACC2 
+    3435 LTINT 
+    3436 BRANCHIF 3452
+    3438 CONST0 
+    3439 PUSHACC3 
+    3440 LTINT 
+    3441 BRANCHIF 3452
+    3443 ACC0 
+    3444 C_CALL1 ml_string_length
+    3446 PUSHACC3 
+    3447 PUSHACC3 
+    3448 ADDINT 
+    3449 GTINT 
+    3450 BRANCHIFNOT 3459
+    3452 GETGLOBAL "String.fill"
+    3454 PUSHGETGLOBALFIELD Pervasives, 2
+    3457 APPTERM1 5
+    3459 ACC3 
+    3460 PUSHACC3 
+    3461 PUSHACC3 
+    3462 PUSHACC3 
+    3463 C_CALL4 fill_string
+    3465 RETURN 4
+    3467 RESTART 
+    3468 GRAB 2
+    3470 CONST0 
+    3471 PUSHACC2 
+    3472 LTINT 
+    3473 BRANCHIF 3489
+    3475 CONST0 
+    3476 PUSHACC3 
+    3477 LTINT 
+    3478 BRANCHIF 3489
+    3480 ACC0 
+    3481 C_CALL1 ml_string_length
+    3483 PUSHACC3 
+    3484 PUSHACC3 
+    3485 ADDINT 
+    3486 GTINT 
+    3487 BRANCHIFNOT 3496
+    3489 GETGLOBAL "String.sub"
+    3491 PUSHGETGLOBALFIELD Pervasives, 2
+    3494 APPTERM1 4
+    3496 ACC2 
+    3497 C_CALL1 create_string
+    3499 PUSHACC3 
+    3500 PUSHCONST0 
+    3501 PUSHACC2 
+    3502 PUSHACC5 
+    3503 PUSHACC5 
+    3504 C_CALL5 blit_string
+    3506 ACC0 
+    3507 RETURN 4
+    3509 ACC0 
+    3510 C_CALL1 ml_string_length
+    3512 PUSHACC0 
+    3513 C_CALL1 create_string
+    3515 PUSHACC1 
+    3516 PUSHCONST0 
+    3517 PUSHACC2 
+    3518 PUSHCONST0 
+    3519 PUSHACC6 
+    3520 C_CALL5 blit_string
+    3522 ACC0 
+    3523 RETURN 3
+    3525 RESTART 
+    3526 GRAB 1
+    3528 ACC0 
+    3529 C_CALL1 create_string
+    3531 PUSHACC2 
+    3532 PUSHACC2 
+    3533 PUSHCONST0 
+    3534 PUSHACC3 
+    3535 C_CALL4 fill_string
+    3537 ACC0 
+    3538 RETURN 3
+    3540 CLOSURE 0, 3526
+    3543 PUSH 
+    3544 CLOSURE 0, 3509
+    3547 PUSH 
+    3548 CLOSURE 0, 3468
+    3551 PUSH 
+    3552 CLOSURE 0, 3431
+    3555 PUSH 
+    3556 CLOSURE 0, 3379
+    3559 PUSH 
+    3560 CLOSURE 0, 3308
+    3563 PUSH 
+    3564 CLOSURE 0, 3013
+    3567 PUSH 
+    3568 CLOSURE 0, 2965
+    3571 PUSHACC0 
+    3572 CLOSURE 1, 2957
+    3575 PUSHACC1 
+    3576 CLOSURE 1, 2950
+    3579 PUSHACC 8
+    3581 CLOSURE 1, 2924
+    3584 PUSHACC0 
+    3585 CLOSURE 1, 2916
+    3588 PUSHACC1 
+    3589 CLOSURE 1, 2909
+    3592 PUSH 
+    3593 CLOSUREREC 0, 2651
+    3597 ACC0 
+    3598 CLOSURE 1, 2897
+    3601 PUSHACC1 
+    3602 CLOSURE 1, 2865
+    3605 PUSH 
+    3606 CLOSUREREC 0, 2684
+    3610 ACC0 
+    3611 CLOSURE 1, 2852
+    3614 PUSHACC1 
+    3615 CLOSURE 1, 2824
+    3618 PUSHACC5 
+    3619 CLOSURE 1, 2769
+    3622 PUSHACC3 
+    3623 CLOSURE 1, 2724
+    3626 PUSHACC1 
+    3627 CLOSURE 1, 2715
+    3630 PUSHACC 9
+    3632 PUSHACC 11
+    3634 PUSHACC 14
+    3636 PUSHACC 16
+    3638 PUSHACC5 
+    3639 PUSHACC7 
+    3640 PUSHACC6 
+    3641 PUSHACC 10
+    3643 PUSHACC 14
+    3645 PUSHACC 13
+    3647 PUSHACC 17
+    3649 PUSHACC 26
+    3651 PUSHACC 28
+    3653 PUSHACC 30
+    3655 PUSHACC 32
+    3657 PUSHACC 34
+    3659 PUSHACC 36
+    3661 PUSHACC 38
+    3663 MAKEBLOCK 18, 0
+    3666 POP 22
+    3668 SETGLOBAL String
+    3670 GETGLOBAL ""
+    3672 PUSHCONSTINT 20
+    3674 C_CALL2 make_vect
+    3676 PUSHCONSTINT 20
+    3678 C_CALL1 weak_create
+    3680 PUSHCONST0 
+    3681 PUSHCONSTINT 19
+    3683 PUSH 
+    3684 BRANCH 3712
+    3686 CHECK_SIGNALS 
+    3687 CONSTINT 115
+    3689 PUSHCONSTINT 20
+    3691 PUSHGETGLOBALFIELD String, 0
+    3694 APPLY2 
+    3695 PUSHACC2 
+    3696 PUSHACC5 
+    3697 SETVECTITEM 
+    3698 ACC1 
+    3699 PUSHACC4 
+    3700 GETVECTITEM 
+    3701 MAKEBLOCK1 0
+    3703 PUSHACC2 
+    3704 PUSHACC4 
+    3705 C_CALL3 weak_set
+    3707 ACC1 
+    3708 OFFSETINT 1
+    3710 ASSIGN 1
+    3712 ACC0 
+    3713 PUSHACC2 
+    3714 LEINT 
+    3715 BRANCHIF 3686
+    3717 CONST0 
+    3718 POP 2
+    3720 CONST0 
+    3721 C_CALL1 gc_full_major
+    3723 CONST0 
+    3724 PUSHCONSTINT 19
+    3726 PUSH 
+    3727 BRANCH 3750
+    3729 CHECK_SIGNALS 
+    3730 ACC1 
+    3731 PUSHACC3 
+    3732 C_CALL2 weak_get
+    3734 PUSHACC0 
+    3735 BRANCHIF 3742
+    3737 GETGLOBAL Not_found
+    3739 MAKEBLOCK1 0
+    3741 RAISE 
+    3742 CONST0 
+    3743 POP 1
+    3745 ACC1 
+    3746 OFFSETINT 1
+    3748 ASSIGN 1
+    3750 ACC0 
+    3751 PUSHACC2 
+    3752 LEINT 
+    3753 BRANCHIF 3729
+    3755 CONST0 
+    3756 POP 2
+    3758 CONST0 
+    3759 PUSHCONSTINT 19
+    3761 PUSH 
+    3762 BRANCH 3782
+    3764 CHECK_SIGNALS 
+    3765 CONST0 
+    3766 PUSHCONST2 
+    3767 PUSHACC3 
+    3768 MODINT 
+    3769 EQ 
+    3770 BRANCHIFNOT 3777
+    3772 GETGLOBAL ""
+    3774 PUSHACC2 
+    3775 PUSHACC5 
+    3776 SETVECTITEM 
+    3777 ACC1 
+    3778 OFFSETINT 1
+    3780 ASSIGN 1
+    3782 ACC0 
+    3783 PUSHACC2 
+    3784 LEINT 
+    3785 BRANCHIF 3764
+    3787 CONST0 
+    3788 POP 2
+    3790 CONST0 
+    3791 C_CALL1 gc_full_major
+    3793 CONST0 
+    3794 PUSHCONSTINT 19
+    3796 PUSH 
+    3797 BRANCH 3851
+    3799 CHECK_SIGNALS 
+    3800 ACC1 
+    3801 PUSHACC3 
+    3802 C_CALL2 weak_get
+    3804 PUSHACC0 
+    3805 BRANCHIFNOT 3829
+    3807 CONST1 
+    3808 PUSHCONST2 
+    3809 PUSHACC4 
+    3810 MODINT 
+    3811 EQ 
+    3812 BRANCHIFNOT 3839
+    3814 CONSTINT 115
+    3816 PUSHCONSTINT 5
+    3818 PUSHACC2 
+    3819 GETFIELD0 
+    3820 GETSTRINGCHAR 
+    3821 NEQ 
+    3822 BRANCHIFNOT 3844
+    3824 GETGLOBAL Not_found
+    3826 MAKEBLOCK1 0
+    3828 RAISE 
+    3829 CONST0 
+    3830 PUSHCONST2 
+    3831 PUSHACC4 
+    3832 MODINT 
+    3833 EQ 
+    3834 BRANCHIFNOT 3839
+    3836 CONST0 
+    3837 BRANCH 3844
+    3839 GETGLOBAL Not_found
+    3841 MAKEBLOCK1 0
+    3843 RAISE 
+    3844 POP 1
+    3846 ACC1 
+    3847 OFFSETINT 1
+    3849 ASSIGN 1
+    3851 ACC0 
+    3852 PUSHACC2 
+    3853 LEINT 
+    3854 BRANCHIF 3799
+    3856 CONST0 
+    3857 POP 4
+    3859 ATOM0 
+    3860 SETGLOBAL T340-weak
+    3862 STOP 
+**)
diff --git a/test/testinterp/t350-heapcheck.ml b/test/testinterp/t350-heapcheck.ml
new file mode 100644
index 00000000..ef4557cd
--- /dev/null
+++ b/test/testinterp/t350-heapcheck.ml
@@ -0,0 +1,2554 @@
+open Lib;;
+ignore (Gc.stat ());
+let x = Array.make 20 "" in
+let w = weak_create 20 in
+for i = 0 to 19 do
+  x.(i) <- String.make 20 's';
+  weak_set w i (Some x.(i));
+done;
+Gc.full_major ();
+for i = 0 to 19 do
+  match weak_get w i with
+  | None -> raise Not_found
+  | _ -> ()
+done;
+for i = 0 to 19 do
+  if i mod 2 = 0 then x.(i) <- ""
+done;
+Gc.full_major ();
+for i = 0 to 19 do
+  match weak_get w i with
+  | None when i mod 2 = 0 -> ()
+  | Some s when i mod 2 = 1 -> if s.[5] <> 's' then raise Not_found
+  | _ -> raise Not_found
+done
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 746
+      11 RESTART 
+      12 GRAB 1
+      14 ACC0 
+      15 BRANCHIFNOT 28
+      17 ACC1 
+      18 PUSHACC1 
+      19 GETFIELD1 
+      20 PUSHOFFSETCLOSURE0 
+      21 APPLY2 
+      22 PUSHACC1 
+      23 GETFIELD0 
+      24 MAKEBLOCK2 0
+      26 RETURN 2
+      28 ACC1 
+      29 RETURN 2
+      31 RESTART 
+      32 GRAB 3
+      34 CONST0 
+      35 PUSHACC4 
+      36 LEINT 
+      37 BRANCHIFNOT 42
+      39 CONST0 
+      40 RETURN 4
+      42 ACC3 
+      43 PUSHACC3 
+      44 PUSHACC3 
+      45 PUSHACC3 
+      46 C_CALL4 caml_input
+      48 PUSHCONST0 
+      49 PUSHACC1 
+      50 EQ 
+      51 BRANCHIFNOT 58
+      53 GETGLOBAL End_of_file
+      55 MAKEBLOCK1 0
+      57 RAISE 
+      58 ACC0 
+      59 PUSHACC5 
+      60 SUBINT 
+      61 PUSHACC1 
+      62 PUSHACC5 
+      63 ADDINT 
+      64 PUSHACC4 
+      65 PUSHACC4 
+      66 PUSHOFFSETCLOSURE0 
+      67 APPTERM 4, 9
+      70 ACC0 
+      71 C_CALL1 caml_input_scan_line
+      73 PUSHCONST0 
+      74 PUSHACC1 
+      75 EQ 
+      76 BRANCHIFNOT 83
+      78 GETGLOBAL End_of_file
+      80 MAKEBLOCK1 0
+      82 RAISE 
+      83 CONST0 
+      84 PUSHACC1 
+      85 GTINT 
+      86 BRANCHIFNOT 107
+      88 ACC0 
+      89 OFFSETINT -1
+      91 C_CALL1 create_string
+      93 PUSHACC1 
+      94 OFFSETINT -1
+      96 PUSHCONST0 
+      97 PUSHACC2 
+      98 PUSHACC5 
+      99 C_CALL4 caml_input
+     101 ACC2 
+     102 C_CALL1 caml_input_char
+     104 ACC0 
+     105 RETURN 3
+     107 ACC0 
+     108 NEGINT 
+     109 C_CALL1 create_string
+     111 PUSHACC1 
+     112 NEGINT 
+     113 PUSHCONST0 
+     114 PUSHACC2 
+     115 PUSHACC5 
+     116 C_CALL4 caml_input
+     118 CONST0 
+     119 PUSHTRAP 130
+     121 ACC6 
+     122 PUSHOFFSETCLOSURE0 
+     123 APPLY1 
+     124 PUSHACC5 
+     125 PUSHENVACC1 
+     126 APPLY2 
+     127 POPTRAP 
+     128 RETURN 3
+     130 PUSHGETGLOBAL End_of_file
+     132 PUSHACC1 
+     133 GETFIELD0 
+     134 EQ 
+     135 BRANCHIFNOT 140
+     137 ACC1 
+     138 RETURN 4
+     140 ACC0 
+     141 RAISE 
+     142 ACC0 
+     143 C_CALL1 caml_flush
+     145 RETURN 1
+     147 RESTART 
+     148 GRAB 1
+     150 ACC1 
+     151 PUSHACC1 
+     152 C_CALL2 caml_output_char
+     154 RETURN 2
+     156 RESTART 
+     157 GRAB 1
+     159 ACC1 
+     160 PUSHACC1 
+     161 C_CALL2 caml_output_char
+     163 RETURN 2
+     165 RESTART 
+     166 GRAB 1
+     168 ACC1 
+     169 PUSHACC1 
+     170 C_CALL2 caml_output_int
+     172 RETURN 2
+     174 RESTART 
+     175 GRAB 1
+     177 ACC1 
+     178 PUSHACC1 
+     179 C_CALL2 caml_seek_out
+     181 RETURN 2
+     183 ACC0 
+     184 C_CALL1 caml_pos_out
+     186 RETURN 1
+     188 ACC0 
+     189 C_CALL1 caml_channel_size
+     191 RETURN 1
+     193 RESTART 
+     194 GRAB 1
+     196 ACC1 
+     197 PUSHACC1 
+     198 C_CALL2 caml_set_binary_mode
+     200 RETURN 2
+     202 ACC0 
+     203 C_CALL1 caml_input_char
+     205 RETURN 1
+     207 ACC0 
+     208 C_CALL1 caml_input_char
+     210 RETURN 1
+     212 ACC0 
+     213 C_CALL1 caml_input_int
+     215 RETURN 1
+     217 ACC0 
+     218 C_CALL1 input_value
+     220 RETURN 1
+     222 RESTART 
+     223 GRAB 1
+     225 ACC1 
+     226 PUSHACC1 
+     227 C_CALL2 caml_seek_in
+     229 RETURN 2
+     231 ACC0 
+     232 C_CALL1 caml_pos_in
+     234 RETURN 1
+     236 ACC0 
+     237 C_CALL1 caml_channel_size
+     239 RETURN 1
+     241 ACC0 
+     242 C_CALL1 caml_close_channel
+     244 RETURN 1
+     246 RESTART 
+     247 GRAB 1
+     249 ACC1 
+     250 PUSHACC1 
+     251 C_CALL2 caml_set_binary_mode
+     253 RETURN 2
+     255 CONST0 
+     256 PUSHENVACC1 
+     257 APPLY1 
+     258 ACC0 
+     259 C_CALL1 sys_exit
+     261 RETURN 1
+     263 CONST0 
+     264 PUSHENVACC1 
+     265 GETFIELD0 
+     266 APPTERM1 2
+     268 CONST0 
+     269 PUSHENVACC1 
+     270 APPLY1 
+     271 CONST0 
+     272 PUSHENVACC2 
+     273 APPTERM1 2
+     275 ENVACC1 
+     276 GETFIELD0 
+     277 PUSHACC0 
+     278 PUSHACC2 
+     279 CLOSURE 2, 268
+     282 PUSHENVACC1 
+     283 SETFIELD0 
+     284 RETURN 2
+     286 ENVACC1 
+     287 C_CALL1 caml_flush
+     289 ENVACC2 
+     290 C_CALL1 caml_flush
+     292 RETURN 1
+     294 CONST0 
+     295 PUSHENVACC1 
+     296 APPLY1 
+     297 C_CALL1 float_of_string
+     299 RETURN 1
+     301 CONST0 
+     302 PUSHENVACC1 
+     303 APPLY1 
+     304 C_CALL1 int_of_string
+     306 RETURN 1
+     308 ENVACC2 
+     309 C_CALL1 caml_flush
+     311 ENVACC1 
+     312 PUSHENVACC3 
+     313 APPTERM1 2
+     315 CONSTINT 13
+     317 PUSHENVACC1 
+     318 C_CALL2 caml_output_char
+     320 ENVACC1 
+     321 C_CALL1 caml_flush
+     323 RETURN 1
+     325 ACC0 
+     326 PUSHENVACC1 
+     327 PUSHENVACC2 
+     328 APPLY2 
+     329 CONSTINT 13
+     331 PUSHENVACC1 
+     332 C_CALL2 caml_output_char
+     334 ENVACC1 
+     335 C_CALL1 caml_flush
+     337 RETURN 1
+     339 ACC0 
+     340 PUSHENVACC1 
+     341 APPLY1 
+     342 PUSHENVACC2 
+     343 PUSHENVACC3 
+     344 APPTERM2 3
+     346 ACC0 
+     347 PUSHENVACC1 
+     348 APPLY1 
+     349 PUSHENVACC2 
+     350 PUSHENVACC3 
+     351 APPTERM2 3
+     353 ACC0 
+     354 PUSHENVACC1 
+     355 PUSHENVACC2 
+     356 APPTERM2 3
+     358 ACC0 
+     359 PUSHENVACC1 
+     360 C_CALL2 caml_output_char
+     362 RETURN 1
+     364 CONSTINT 13
+     366 PUSHENVACC1 
+     367 C_CALL2 caml_output_char
+     369 ENVACC1 
+     370 C_CALL1 caml_flush
+     372 RETURN 1
+     374 ACC0 
+     375 PUSHENVACC1 
+     376 PUSHENVACC2 
+     377 APPLY2 
+     378 CONSTINT 13
+     380 PUSHENVACC1 
+     381 C_CALL2 caml_output_char
+     383 RETURN 1
+     385 ACC0 
+     386 PUSHENVACC1 
+     387 APPLY1 
+     388 PUSHENVACC2 
+     389 PUSHENVACC3 
+     390 APPTERM2 3
+     392 ACC0 
+     393 PUSHENVACC1 
+     394 APPLY1 
+     395 PUSHENVACC2 
+     396 PUSHENVACC3 
+     397 APPTERM2 3
+     399 ACC0 
+     400 PUSHENVACC1 
+     401 PUSHENVACC2 
+     402 APPTERM2 3
+     404 ACC0 
+     405 PUSHENVACC1 
+     406 C_CALL2 caml_output_char
+     408 RETURN 1
+     410 RESTART 
+     411 GRAB 3
+     413 CONST0 
+     414 PUSHACC3 
+     415 LTINT 
+     416 BRANCHIF 427
+     418 ACC1 
+     419 C_CALL1 ml_string_length
+     421 PUSHACC4 
+     422 PUSHACC4 
+     423 ADDINT 
+     424 GTINT 
+     425 BRANCHIFNOT 432
+     427 GETGLOBAL "really_input"
+     429 PUSHENVACC1 
+     430 APPTERM1 5
+     432 ACC3 
+     433 PUSHACC3 
+     434 PUSHACC3 
+     435 PUSHACC3 
+     436 PUSHENVACC2 
+     437 APPTERM 4, 8
+     440 RESTART 
+     441 GRAB 3
+     443 CONST0 
+     444 PUSHACC3 
+     445 LTINT 
+     446 BRANCHIF 457
+     448 ACC1 
+     449 C_CALL1 ml_string_length
+     451 PUSHACC4 
+     452 PUSHACC4 
+     453 ADDINT 
+     454 GTINT 
+     455 BRANCHIFNOT 462
+     457 GETGLOBAL "input"
+     459 PUSHENVACC1 
+     460 APPTERM1 5
+     462 ACC3 
+     463 PUSHACC3 
+     464 PUSHACC3 
+     465 PUSHACC3 
+     466 C_CALL4 caml_input
+     468 RETURN 4
+     470 ACC0 
+     471 PUSHCONST0 
+     472 PUSHGETGLOBAL <0>(0, <0>(6, 0))
+     474 PUSHENVACC1 
+     475 APPTERM3 4
+     477 ACC0 
+     478 PUSHCONST0 
+     479 PUSHGETGLOBAL <0>(0, <0>(7, 0))
+     481 PUSHENVACC1 
+     482 APPTERM3 4
+     484 RESTART 
+     485 GRAB 2
+     487 ACC1 
+     488 PUSHACC1 
+     489 PUSHACC4 
+     490 C_CALL3 sys_open
+     492 C_CALL1 caml_open_descriptor
+     494 RETURN 3
+     496 ACC0 
+     497 C_CALL1 caml_flush
+     499 ACC0 
+     500 C_CALL1 caml_close_channel
+     502 RETURN 1
+     504 RESTART 
+     505 GRAB 1
+     507 CONST0 
+     508 PUSHACC2 
+     509 PUSHACC2 
+     510 C_CALL3 output_value
+     512 RETURN 2
+     514 RESTART 
+     515 GRAB 3
+     517 CONST0 
+     518 PUSHACC3 
+     519 LTINT 
+     520 BRANCHIF 531
+     522 ACC1 
+     523 C_CALL1 ml_string_length
+     525 PUSHACC4 
+     526 PUSHACC4 
+     527 ADDINT 
+     528 GTINT 
+     529 BRANCHIFNOT 536
+     531 GETGLOBAL "output"
+     533 PUSHENVACC1 
+     534 APPTERM1 5
+     536 ACC3 
+     537 PUSHACC3 
+     538 PUSHACC3 
+     539 PUSHACC3 
+     540 C_CALL4 caml_output
+     542 RETURN 4
+     544 RESTART 
+     545 GRAB 1
+     547 ACC1 
+     548 C_CALL1 ml_string_length
+     550 PUSHCONST0 
+     551 PUSHACC3 
+     552 PUSHACC3 
+     553 C_CALL4 caml_output
+     555 RETURN 2
+     557 ACC0 
+     558 PUSHCONSTINT 438
+     560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0))))
+     562 PUSHENVACC1 
+     563 APPTERM3 4
+     565 ACC0 
+     566 PUSHCONSTINT 438
+     568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0))))
+     570 PUSHENVACC1 
+     571 APPTERM3 4
+     573 RESTART 
+     574 GRAB 2
+     576 ACC1 
+     577 PUSHACC1 
+     578 PUSHACC4 
+     579 C_CALL3 sys_open
+     581 C_CALL1 caml_open_descriptor
+     583 RETURN 3
+     585 ACC0 
+     586 PUSHGETGLOBAL "%.12g"
+     588 C_CALL2 format_float
+     590 RETURN 1
+     592 ACC0 
+     593 PUSHGETGLOBAL "%d"
+     595 C_CALL2 format_int
+     597 RETURN 1
+     599 GETGLOBAL "false"
+     601 PUSHACC1 
+     602 C_CALL2 string_equal
+     604 BRANCHIFNOT 609
+     606 CONST0 
+     607 RETURN 1
+     609 GETGLOBAL "true"
+     611 PUSHACC1 
+     612 C_CALL2 string_equal
+     614 BRANCHIFNOT 619
+     616 CONST1 
+     617 RETURN 1
+     619 GETGLOBAL "bool_of_string"
+     621 PUSHENVACC1 
+     622 APPTERM1 2
+     624 ACC0 
+     625 BRANCHIFNOT 631
+     627 GETGLOBAL "true"
+     629 RETURN 1
+     631 GETGLOBAL "false"
+     633 RETURN 1
+     635 CONST0 
+     636 PUSHACC1 
+     637 LTINT 
+     638 BRANCHIF 646
+     640 CONSTINT 255
+     642 PUSHACC1 
+     643 GTINT 
+     644 BRANCHIFNOT 651
+     646 GETGLOBAL "char_of_int"
+     648 PUSHENVACC1 
+     649 APPTERM1 2
+     651 ACC0 
+     652 RETURN 1
+     654 RESTART 
+     655 GRAB 1
+     657 ACC0 
+     658 C_CALL1 ml_string_length
+     660 PUSHACC2 
+     661 C_CALL1 ml_string_length
+     663 PUSHACC0 
+     664 PUSHACC2 
+     665 ADDINT 
+     666 C_CALL1 create_string
+     668 PUSHACC2 
+     669 PUSHCONST0 
+     670 PUSHACC2 
+     671 PUSHCONST0 
+     672 PUSHACC7 
+     673 C_CALL5 blit_string
+     675 ACC1 
+     676 PUSHACC3 
+     677 PUSHACC2 
+     678 PUSHCONST0 
+     679 PUSHACC 8
+     681 C_CALL5 blit_string
+     683 ACC0 
+     684 RETURN 5
+     686 CONSTINT -1
+     688 PUSHACC1 
+     689 XORINT 
+     690 RETURN 1
+     692 CONST0 
+     693 PUSHACC1 
+     694 GEINT 
+     695 BRANCHIFNOT 700
+     697 ACC0 
+     698 RETURN 1
+     700 ACC0 
+     701 NEGINT 
+     702 RETURN 1
+     704 RESTART 
+     705 GRAB 1
+     707 ACC1 
+     708 PUSHACC1 
+     709 C_CALL2 greaterequal
+     711 BRANCHIFNOT 716
+     713 ACC0 
+     714 RETURN 2
+     716 ACC1 
+     717 RETURN 2
+     719 RESTART 
+     720 GRAB 1
+     722 ACC1 
+     723 PUSHACC1 
+     724 C_CALL2 lessequal
+     726 BRANCHIFNOT 731
+     728 ACC0 
+     729 RETURN 2
+     731 ACC1 
+     732 RETURN 2
+     734 ACC0 
+     735 PUSHGETGLOBAL Invalid_argument
+     737 MAKEBLOCK2 0
+     739 RAISE 
+     740 ACC0 
+     741 PUSHGETGLOBAL Failure
+     743 MAKEBLOCK2 0
+     745 RAISE 
+     746 CLOSURE 0, 740
+     749 PUSH 
+     750 CLOSURE 0, 734
+     753 PUSHGETGLOBAL "Pervasives.Exit"
+     755 MAKEBLOCK1 0
+     757 PUSHGETGLOBAL "Pervasives.Assert_failure"
+     759 MAKEBLOCK1 0
+     761 PUSH 
+     762 CLOSURE 0, 720
+     765 PUSH 
+     766 CLOSURE 0, 705
+     769 PUSH 
+     770 CLOSURE 0, 692
+     773 PUSH 
+     774 CLOSURE 0, 686
+     777 PUSHCONST0 
+     778 PUSHCONSTINT 31
+     780 PUSHCONST1 
+     781 LSLINT 
+     782 EQ 
+     783 BRANCHIFNOT 789
+     785 CONSTINT 30
+     787 BRANCH 791
+     789 CONSTINT 62
+     791 PUSHCONST1 
+     792 LSLINT 
+     793 PUSHACC0 
+     794 OFFSETINT -1
+     796 PUSH 
+     797 CLOSURE 0, 655
+     800 PUSHACC 9
+     802 CLOSURE 1, 635
+     805 PUSH 
+     806 CLOSURE 0, 624
+     809 PUSHACC 11
+     811 CLOSURE 1, 599
+     814 PUSH 
+     815 CLOSURE 0, 592
+     818 PUSH 
+     819 CLOSURE 0, 585
+     822 PUSH 
+     823 CLOSUREREC 0, 12
+     827 CONST0 
+     828 C_CALL1 caml_open_descriptor
+     830 PUSHCONST1 
+     831 C_CALL1 caml_open_descriptor
+     833 PUSHCONST2 
+     834 C_CALL1 caml_open_descriptor
+     836 PUSH 
+     837 CLOSURE 0, 574
+     840 PUSHACC0 
+     841 CLOSURE 1, 565
+     844 PUSHACC1 
+     845 CLOSURE 1, 557
+     848 PUSH 
+     849 CLOSURE 0, 545
+     852 PUSHACC 22
+     854 CLOSURE 1, 515
+     857 PUSH 
+     858 CLOSURE 0, 505
+     861 PUSH 
+     862 CLOSURE 0, 496
+     865 PUSH 
+     866 CLOSURE 0, 485
+     869 PUSHACC0 
+     870 CLOSURE 1, 477
+     873 PUSHACC1 
+     874 CLOSURE 1, 470
+     877 PUSHACC 28
+     879 CLOSURE 1, 441
+     882 PUSH 
+     883 CLOSUREREC 0, 32
+     887 ACC0 
+     888 PUSHACC 31
+     890 CLOSURE 2, 411
+     893 PUSHACC 22
+     895 CLOSUREREC 1, 70
+     899 ACC 15
+     901 CLOSURE 1, 404
+     904 PUSHACC 11
+     906 PUSHACC 17
+     908 CLOSURE 2, 399
+     911 PUSHACC 12
+     913 PUSHACC 18
+     915 PUSHACC 23
+     917 CLOSURE 3, 392
+     920 PUSHACC 13
+     922 PUSHACC 19
+     924 PUSHACC 23
+     926 CLOSURE 3, 385
+     929 PUSHACC 14
+     931 PUSHACC 20
+     933 CLOSURE 2, 374
+     936 PUSHACC 20
+     938 CLOSURE 1, 364
+     941 PUSHACC 20
+     943 CLOSURE 1, 358
+     946 PUSHACC 17
+     948 PUSHACC 22
+     950 CLOSURE 2, 353
+     953 PUSHACC 18
+     955 PUSHACC 23
+     957 PUSHACC 29
+     959 CLOSURE 3, 346
+     962 PUSHACC 19
+     964 PUSHACC 24
+     966 PUSHACC 29
+     968 CLOSURE 3, 339
+     971 PUSHACC 20
+     973 PUSHACC 25
+     975 CLOSURE 2, 325
+     978 PUSHACC 25
+     980 CLOSURE 1, 315
+     983 PUSHACC 12
+     985 PUSHACC 28
+     987 PUSHACC 30
+     989 CLOSURE 3, 308
+     992 PUSHACC0 
+     993 CLOSURE 1, 301
+     996 PUSHACC1 
+     997 CLOSURE 1, 294
+    1000 PUSHACC 29
+    1002 PUSHACC 31
+    1004 CLOSURE 2, 286
+    1007 MAKEBLOCK1 0
+    1009 PUSHACC0 
+    1010 CLOSURE 1, 275
+    1013 PUSHACC1 
+    1014 CLOSURE 1, 263
+    1017 PUSHACC0 
+    1018 CLOSURE 1, 255
+    1021 PUSHACC1 
+    1022 PUSHACC 22
+    1024 PUSHACC4 
+    1025 PUSHACC3 
+    1026 PUSH 
+    1027 CLOSURE 0, 247
+    1030 PUSH 
+    1031 CLOSURE 0, 241
+    1034 PUSH 
+    1035 CLOSURE 0, 236
+    1038 PUSH 
+    1039 CLOSURE 0, 231
+    1042 PUSH 
+    1043 CLOSURE 0, 223
+    1046 PUSH 
+    1047 CLOSURE 0, 217
+    1050 PUSH 
+    1051 CLOSURE 0, 212
+    1054 PUSH 
+    1055 CLOSURE 0, 207
+    1058 PUSHACC 32
+    1060 PUSHACC 35
+    1062 PUSHACC 33
+    1064 PUSH 
+    1065 CLOSURE 0, 202
+    1068 PUSHACC 41
+    1070 PUSHACC 40
+    1072 PUSHACC 42
+    1074 PUSH 
+    1075 CLOSURE 0, 194
+    1078 PUSHACC 46
+    1080 PUSH 
+    1081 CLOSURE 0, 188
+    1084 PUSH 
+    1085 CLOSURE 0, 183
+    1088 PUSH 
+    1089 CLOSURE 0, 175
+    1092 PUSHACC 51
+    1094 PUSH 
+    1095 CLOSURE 0, 166
+    1098 PUSH 
+    1099 CLOSURE 0, 157
+    1102 PUSHACC 55
+    1104 PUSHACC 57
+    1106 PUSH 
+    1107 CLOSURE 0, 148
+    1110 PUSH 
+    1111 CLOSURE 0, 142
+    1114 PUSHACC 63
+    1116 PUSHACC 62
+    1118 PUSHACC 64
+    1120 PUSHACC 38
+    1122 PUSHACC 40
+    1124 PUSHACC 42
+    1126 PUSHACC 44
+    1128 PUSHACC 46
+    1130 PUSHACC 48
+    1132 PUSHACC 50
+    1134 PUSHACC 52
+    1136 PUSHACC 54
+    1138 PUSHACC 56
+    1140 PUSHACC 58
+    1142 PUSHACC 60
+    1144 PUSHACC 62
+    1146 PUSHACC 64
+    1148 PUSHACC 66
+    1150 PUSHACC 82
+    1152 PUSHACC 84
+    1154 PUSHACC 86
+    1156 PUSHACC 88
+    1158 PUSHACC 90
+    1160 PUSHACC 92
+    1162 PUSHACC 94
+    1164 PUSHACC 96
+    1166 PUSHACC 98
+    1168 PUSHACC 100
+    1170 PUSHACC 104
+    1172 PUSHACC 104
+    1174 PUSHACC 104
+    1176 PUSHACC 108
+    1178 PUSHACC 110
+    1180 PUSHACC 112
+    1182 PUSHACC 117
+    1184 PUSHACC 117
+    1186 PUSHACC 117
+    1188 PUSHACC 117
+    1190 MAKEBLOCK 69, 0
+    1193 POP 53
+    1195 SETGLOBAL Pervasives
+    1197 BRANCH 2177
+    1199 RESTART 
+    1200 GRAB 1
+    1202 ACC1 
+    1203 BRANCHIFNOT 1213
+    1205 ACC1 
+    1206 GETFIELD1 
+    1207 PUSHACC1 
+    1208 OFFSETINT 1
+    1210 PUSHOFFSETCLOSURE0 
+    1211 APPTERM2 4
+    1213 ACC0 
+    1214 RETURN 2
+    1216 RESTART 
+    1217 GRAB 1
+    1219 ACC0 
+    1220 BRANCHIFNOT 1251
+    1222 CONST0 
+    1223 PUSHACC2 
+    1224 EQ 
+    1225 BRANCHIFNOT 1231
+    1227 ACC0 
+    1228 GETFIELD0 
+    1229 RETURN 2
+    1231 CONST0 
+    1232 PUSHACC2 
+    1233 GTINT 
+    1234 BRANCHIFNOT 1244
+    1236 ACC1 
+    1237 OFFSETINT -1
+    1239 PUSHACC1 
+    1240 GETFIELD1 
+    1241 PUSHOFFSETCLOSURE0 
+    1242 APPTERM2 4
+    1244 GETGLOBAL "List.nth"
+    1246 PUSHGETGLOBALFIELD Pervasives, 2
+    1249 APPTERM1 3
+    1251 GETGLOBAL "nth"
+    1253 PUSHGETGLOBALFIELD Pervasives, 3
+    1256 APPTERM1 3
+    1258 RESTART 
+    1259 GRAB 1
+    1261 ACC0 
+    1262 BRANCHIFNOT 1274
+    1264 ACC1 
+    1265 PUSHACC1 
+    1266 GETFIELD0 
+    1267 MAKEBLOCK2 0
+    1269 PUSHACC1 
+    1270 GETFIELD1 
+    1271 PUSHOFFSETCLOSURE0 
+    1272 APPTERM2 4
+    1274 ACC1 
+    1275 RETURN 2
+    1277 ACC0 
+    1278 BRANCHIFNOT 1291
+    1280 ACC0 
+    1281 GETFIELD1 
+    1282 PUSHOFFSETCLOSURE0 
+    1283 APPLY1 
+    1284 PUSHACC1 
+    1285 GETFIELD0 
+    1286 PUSHGETGLOBALFIELD Pervasives, 16
+    1289 APPTERM2 3
+    1291 RETURN 1
+    1293 RESTART 
+    1294 GRAB 1
+    1296 ACC1 
+    1297 BRANCHIFNOT 1313
+    1299 ACC1 
+    1300 GETFIELD0 
+    1301 PUSHACC1 
+    1302 APPLY1 
+    1303 PUSHACC2 
+    1304 GETFIELD1 
+    1305 PUSHACC2 
+    1306 PUSHOFFSETCLOSURE0 
+    1307 APPLY2 
+    1308 PUSHACC1 
+    1309 MAKEBLOCK2 0
+    1311 POP 1
+    1313 RETURN 2
+    1315 RESTART 
+    1316 GRAB 1
+    1318 ACC1 
+    1319 BRANCHIFNOT 1331
+    1321 ACC1 
+    1322 GETFIELD0 
+    1323 PUSHACC1 
+    1324 APPLY1 
+    1325 ACC1 
+    1326 GETFIELD1 
+    1327 PUSHACC1 
+    1328 PUSHOFFSETCLOSURE0 
+    1329 APPTERM2 4
+    1331 RETURN 2
+    1333 RESTART 
+    1334 GRAB 2
+    1336 ACC2 
+    1337 BRANCHIFNOT 1350
+    1339 ACC2 
+    1340 GETFIELD1 
+    1341 PUSHACC3 
+    1342 GETFIELD0 
+    1343 PUSHACC3 
+    1344 PUSHACC3 
+    1345 APPLY2 
+    1346 PUSHACC2 
+    1347 PUSHOFFSETCLOSURE0 
+    1348 APPTERM3 6
+    1350 ACC1 
+    1351 RETURN 3
+    1353 RESTART 
+    1354 GRAB 2
+    1356 ACC1 
+    1357 BRANCHIFNOT 1370
+    1359 ACC2 
+    1360 PUSHACC2 
+    1361 GETFIELD1 
+    1362 PUSHACC2 
+    1363 PUSHOFFSETCLOSURE0 
+    1364 APPLY3 
+    1365 PUSHACC2 
+    1366 GETFIELD0 
+    1367 PUSHACC2 
+    1368 APPTERM2 5
+    1370 ACC2 
+    1371 RETURN 3
+    1373 RESTART 
+    1374 GRAB 2
+    1376 ACC1 
+    1377 BRANCHIFNOT 1400
+    1379 ACC2 
+    1380 BRANCHIFNOT 1407
+    1382 ACC2 
+    1383 GETFIELD0 
+    1384 PUSHACC2 
+    1385 GETFIELD0 
+    1386 PUSHACC2 
+    1387 APPLY2 
+    1388 PUSHACC3 
+    1389 GETFIELD1 
+    1390 PUSHACC3 
+    1391 GETFIELD1 
+    1392 PUSHACC3 
+    1393 PUSHOFFSETCLOSURE0 
+    1394 APPLY3 
+    1395 PUSHACC1 
+    1396 MAKEBLOCK2 0
+    1398 RETURN 4
+    1400 ACC2 
+    1401 BRANCHIFNOT 1405
+    1403 BRANCH 1407
+    1405 RETURN 3
+    1407 GETGLOBAL "List.map2"
+    1409 PUSHGETGLOBALFIELD Pervasives, 2
+    1412 APPTERM1 4
+    1414 RESTART 
+    1415 GRAB 2
+    1417 ACC1 
+    1418 BRANCHIFNOT 1437
+    1420 ACC2 
+    1421 BRANCHIFNOT 1444
+    1423 ACC2 
+    1424 GETFIELD0 
+    1425 PUSHACC2 
+    1426 GETFIELD0 
+    1427 PUSHACC2 
+    1428 APPLY2 
+    1429 ACC2 
+    1430 GETFIELD1 
+    1431 PUSHACC2 
+    1432 GETFIELD1 
+    1433 PUSHACC2 
+    1434 PUSHOFFSETCLOSURE0 
+    1435 APPTERM3 6
+    1437 ACC2 
+    1438 BRANCHIFNOT 1442
+    1440 BRANCH 1444
+    1442 RETURN 3
+    1444 GETGLOBAL "List.iter2"
+    1446 PUSHGETGLOBALFIELD Pervasives, 2
+    1449 APPTERM1 4
+    1451 RESTART 
+    1452 GRAB 3
+    1454 ACC2 
+    1455 BRANCHIFNOT 1476
+    1457 ACC3 
+    1458 BRANCHIFNOT 1482
+    1460 ACC3 
+    1461 GETFIELD1 
+    1462 PUSHACC3 
+    1463 GETFIELD1 
+    1464 PUSHACC5 
+    1465 GETFIELD0 
+    1466 PUSHACC5 
+    1467 GETFIELD0 
+    1468 PUSHACC5 
+    1469 PUSHACC5 
+    1470 APPLY3 
+    1471 PUSHACC3 
+    1472 PUSHOFFSETCLOSURE0 
+    1473 APPTERM 4, 8
+    1476 ACC3 
+    1477 BRANCHIF 1482
+    1479 ACC1 
+    1480 RETURN 4
+    1482 GETGLOBAL "List.fold_left2"
+    1484 PUSHGETGLOBALFIELD Pervasives, 2
+    1487 APPTERM1 5
+    1489 RESTART 
+    1490 GRAB 3
+    1492 ACC1 
+    1493 BRANCHIFNOT 1516
+    1495 ACC2 
+    1496 BRANCHIFNOT 1522
+    1498 PUSH_RETADDR 1509
+    1500 ACC6 
+    1501 PUSHACC6 
+    1502 GETFIELD1 
+    1503 PUSHACC6 
+    1504 GETFIELD1 
+    1505 PUSHACC6 
+    1506 PUSHOFFSETCLOSURE0 
+    1507 APPLY 4
+    1509 PUSHACC3 
+    1510 GETFIELD0 
+    1511 PUSHACC3 
+    1512 GETFIELD0 
+    1513 PUSHACC3 
+    1514 APPTERM3 7
+    1516 ACC2 
+    1517 BRANCHIF 1522
+    1519 ACC3 
+    1520 RETURN 4
+    1522 GETGLOBAL "List.fold_right2"
+    1524 PUSHGETGLOBALFIELD Pervasives, 2
+    1527 APPTERM1 5
+    1529 RESTART 
+    1530 GRAB 1
+    1532 ACC1 
+    1533 BRANCHIFNOT 1549
+    1535 ACC1 
+    1536 GETFIELD0 
+    1537 PUSHACC1 
+    1538 APPLY1 
+    1539 BRANCHIFNOT 1547
+    1541 ACC1 
+    1542 GETFIELD1 
+    1543 PUSHACC1 
+    1544 PUSHOFFSETCLOSURE0 
+    1545 APPTERM2 4
+    1547 RETURN 2
+    1549 CONST1 
+    1550 RETURN 2
+    1552 RESTART 
+    1553 GRAB 1
+    1555 ACC1 
+    1556 BRANCHIFNOT 1570
+    1558 ACC1 
+    1559 GETFIELD0 
+    1560 PUSHACC1 
+    1561 APPLY1 
+    1562 BRANCHIF 1570
+    1564 ACC1 
+    1565 GETFIELD1 
+    1566 PUSHACC1 
+    1567 PUSHOFFSETCLOSURE0 
+    1568 APPTERM2 4
+    1570 RETURN 2
+    1572 RESTART 
+    1573 GRAB 2
+    1575 ACC1 
+    1576 BRANCHIFNOT 1599
+    1578 ACC2 
+    1579 BRANCHIFNOT 1605
+    1581 ACC2 
+    1582 GETFIELD0 
+    1583 PUSHACC2 
+    1584 GETFIELD0 
+    1585 PUSHACC2 
+    1586 APPLY2 
+    1587 BRANCHIFNOT 1597
+    1589 ACC2 
+    1590 GETFIELD1 
+    1591 PUSHACC2 
+    1592 GETFIELD1 
+    1593 PUSHACC2 
+    1594 PUSHOFFSETCLOSURE0 
+    1595 APPTERM3 6
+    1597 RETURN 3
+    1599 ACC2 
+    1600 BRANCHIF 1605
+    1602 CONST1 
+    1603 RETURN 3
+    1605 GETGLOBAL "List.for_all2"
+    1607 PUSHGETGLOBALFIELD Pervasives, 2
+    1610 APPTERM1 4
+    1612 RESTART 
+    1613 GRAB 2
+    1615 ACC1 
+    1616 BRANCHIFNOT 1639
+    1618 ACC2 
+    1619 BRANCHIFNOT 1646
+    1621 ACC2 
+    1622 GETFIELD0 
+    1623 PUSHACC2 
+    1624 GETFIELD0 
+    1625 PUSHACC2 
+    1626 APPLY2 
+    1627 BRANCHIF 1637
+    1629 ACC2 
+    1630 GETFIELD1 
+    1631 PUSHACC2 
+    1632 GETFIELD1 
+    1633 PUSHACC2 
+    1634 PUSHOFFSETCLOSURE0 
+    1635 APPTERM3 6
+    1637 RETURN 3
+    1639 ACC2 
+    1640 BRANCHIFNOT 1644
+    1642 BRANCH 1646
+    1644 RETURN 3
+    1646 GETGLOBAL "List.exists2"
+    1648 PUSHGETGLOBALFIELD Pervasives, 2
+    1651 APPTERM1 4
+    1653 RESTART 
+    1654 GRAB 1
+    1656 ACC1 
+    1657 BRANCHIFNOT 1672
+    1659 ACC0 
+    1660 PUSHACC2 
+    1661 GETFIELD0 
+    1662 C_CALL2 equal
+    1664 BRANCHIF 1672
+    1666 ACC1 
+    1667 GETFIELD1 
+    1668 PUSHACC1 
+    1669 PUSHOFFSETCLOSURE0 
+    1670 APPTERM2 4
+    1672 RETURN 2
+    1674 RESTART 
+    1675 GRAB 1
+    1677 ACC1 
+    1678 BRANCHIFNOT 1692
+    1680 ACC0 
+    1681 PUSHACC2 
+    1682 GETFIELD0 
+    1683 EQ 
+    1684 BRANCHIF 1692
+    1686 ACC1 
+    1687 GETFIELD1 
+    1688 PUSHACC1 
+    1689 PUSHOFFSETCLOSURE0 
+    1690 APPTERM2 4
+    1692 RETURN 2
+    1694 RESTART 
+    1695 GRAB 1
+    1697 ACC1 
+    1698 BRANCHIFNOT 1719
+    1700 ACC1 
+    1701 GETFIELD0 
+    1702 PUSHACC1 
+    1703 PUSHACC1 
+    1704 GETFIELD0 
+    1705 C_CALL2 equal
+    1707 BRANCHIFNOT 1713
+    1709 ACC0 
+    1710 GETFIELD1 
+    1711 RETURN 3
+    1713 ACC2 
+    1714 GETFIELD1 
+    1715 PUSHACC2 
+    1716 PUSHOFFSETCLOSURE0 
+    1717 APPTERM2 5
+    1719 GETGLOBAL Not_found
+    1721 MAKEBLOCK1 0
+    1723 RAISE 
+    1724 RESTART 
+    1725 GRAB 1
+    1727 ACC1 
+    1728 BRANCHIFNOT 1748
+    1730 ACC1 
+    1731 GETFIELD0 
+    1732 PUSHACC1 
+    1733 PUSHACC1 
+    1734 GETFIELD0 
+    1735 EQ 
+    1736 BRANCHIFNOT 1742
+    1738 ACC0 
+    1739 GETFIELD1 
+    1740 RETURN 3
+    1742 ACC2 
+    1743 GETFIELD1 
+    1744 PUSHACC2 
+    1745 PUSHOFFSETCLOSURE0 
+    1746 APPTERM2 5
+    1748 GETGLOBAL Not_found
+    1750 MAKEBLOCK1 0
+    1752 RAISE 
+    1753 RESTART 
+    1754 GRAB 1
+    1756 ACC1 
+    1757 BRANCHIFNOT 1773
+    1759 ACC0 
+    1760 PUSHACC2 
+    1761 GETFIELD0 
+    1762 GETFIELD0 
+    1763 C_CALL2 equal
+    1765 BRANCHIF 1773
+    1767 ACC1 
+    1768 GETFIELD1 
+    1769 PUSHACC1 
+    1770 PUSHOFFSETCLOSURE0 
+    1771 APPTERM2 4
+    1773 RETURN 2
+    1775 RESTART 
+    1776 GRAB 1
+    1778 ACC1 
+    1779 BRANCHIFNOT 1794
+    1781 ACC0 
+    1782 PUSHACC2 
+    1783 GETFIELD0 
+    1784 GETFIELD0 
+    1785 EQ 
+    1786 BRANCHIF 1794
+    1788 ACC1 
+    1789 GETFIELD1 
+    1790 PUSHACC1 
+    1791 PUSHOFFSETCLOSURE0 
+    1792 APPTERM2 4
+    1794 RETURN 2
+    1796 RESTART 
+    1797 GRAB 1
+    1799 ACC1 
+    1800 BRANCHIFNOT 1825
+    1802 ACC1 
+    1803 GETFIELD0 
+    1804 PUSHACC2 
+    1805 GETFIELD1 
+    1806 PUSHACC2 
+    1807 PUSHACC2 
+    1808 GETFIELD0 
+    1809 C_CALL2 equal
+    1811 BRANCHIFNOT 1816
+    1813 ACC0 
+    1814 RETURN 4
+    1816 ACC0 
+    1817 PUSHACC3 
+    1818 PUSHOFFSETCLOSURE0 
+    1819 APPLY2 
+    1820 PUSHACC2 
+    1821 MAKEBLOCK2 0
+    1823 POP 2
+    1825 RETURN 2
+    1827 RESTART 
+    1828 GRAB 1
+    1830 ACC1 
+    1831 BRANCHIFNOT 1855
+    1833 ACC1 
+    1834 GETFIELD0 
+    1835 PUSHACC2 
+    1836 GETFIELD1 
+    1837 PUSHACC2 
+    1838 PUSHACC2 
+    1839 GETFIELD0 
+    1840 EQ 
+    1841 BRANCHIFNOT 1846
+    1843 ACC0 
+    1844 RETURN 4
+    1846 ACC0 
+    1847 PUSHACC3 
+    1848 PUSHOFFSETCLOSURE0 
+    1849 APPLY2 
+    1850 PUSHACC2 
+    1851 MAKEBLOCK2 0
+    1853 POP 2
+    1855 RETURN 2
+    1857 RESTART 
+    1858 GRAB 1
+    1860 ACC1 
+    1861 BRANCHIFNOT 1879
+    1863 ACC1 
+    1864 GETFIELD0 
+    1865 PUSHACC0 
+    1866 PUSHACC2 
+    1867 APPLY1 
+    1868 BRANCHIFNOT 1873
+    1870 ACC0 
+    1871 RETURN 3
+    1873 ACC2 
+    1874 GETFIELD1 
+    1875 PUSHACC2 
+    1876 PUSHOFFSETCLOSURE0 
+    1877 APPTERM2 5
+    1879 GETGLOBAL Not_found
+    1881 MAKEBLOCK1 0
+    1883 RAISE 
+    1884 RESTART 
+    1885 GRAB 2
+    1887 ACC2 
+    1888 BRANCHIFNOT 1917
+    1890 ACC2 
+    1891 GETFIELD0 
+    1892 PUSHACC3 
+    1893 GETFIELD1 
+    1894 PUSHACC1 
+    1895 PUSHENVACC2 
+    1896 APPLY1 
+    1897 BRANCHIFNOT 1908
+    1899 ACC0 
+    1900 PUSHACC4 
+    1901 PUSHACC4 
+    1902 PUSHACC4 
+    1903 MAKEBLOCK2 0
+    1905 PUSHOFFSETCLOSURE0 
+    1906 APPTERM3 8
+    1908 ACC0 
+    1909 PUSHACC4 
+    1910 PUSHACC3 
+    1911 MAKEBLOCK2 0
+    1913 PUSHACC4 
+    1914 PUSHOFFSETCLOSURE0 
+    1915 APPTERM3 8
+    1917 ACC1 
+    1918 PUSHENVACC1 
+    1919 APPLY1 
+    1920 PUSHACC1 
+    1921 PUSHENVACC1 
+    1922 APPLY1 
+    1923 MAKEBLOCK2 0
+    1925 RETURN 3
+    1927 RESTART 
+    1928 GRAB 1
+    1930 ACC0 
+    1931 PUSHENVACC1 
+    1932 CLOSUREREC 2, 1885
+    1936 ACC2 
+    1937 PUSHCONST0 
+    1938 PUSHCONST0 
+    1939 PUSHACC3 
+    1940 APPTERM3 6
+    1942 ACC0 
+    1943 BRANCHIFNOT 1967
+    1945 ACC0 
+    1946 GETFIELD0 
+    1947 PUSHACC1 
+    1948 GETFIELD1 
+    1949 PUSHOFFSETCLOSURE0 
+    1950 APPLY1 
+    1951 PUSHACC0 
+    1952 GETFIELD1 
+    1953 PUSHACC2 
+    1954 GETFIELD1 
+    1955 MAKEBLOCK2 0
+    1957 PUSHACC1 
+    1958 GETFIELD0 
+    1959 PUSHACC3 
+    1960 GETFIELD0 
+    1961 MAKEBLOCK2 0
+    1963 MAKEBLOCK2 0
+    1965 RETURN 3
+    1967 GETGLOBAL <0>(0, 0)
+    1969 RETURN 1
+    1971 RESTART 
+    1972 GRAB 1
+    1974 ACC0 
+    1975 BRANCHIFNOT 1996
+    1977 ACC1 
+    1978 BRANCHIFNOT 2003
+    1980 ACC1 
+    1981 GETFIELD1 
+    1982 PUSHACC1 
+    1983 GETFIELD1 
+    1984 PUSHOFFSETCLOSURE0 
+    1985 APPLY2 
+    1986 PUSHACC2 
+    1987 GETFIELD0 
+    1988 PUSHACC2 
+    1989 GETFIELD0 
+    1990 MAKEBLOCK2 0
+    1992 MAKEBLOCK2 0
+    1994 RETURN 2
+    1996 ACC1 
+    1997 BRANCHIFNOT 2001
+    1999 BRANCH 2003
+    2001 RETURN 2
+    2003 GETGLOBAL "List.combine"
+    2005 PUSHGETGLOBALFIELD Pervasives, 2
+    2008 APPTERM1 3
+    2010 RESTART 
+    2011 GRAB 1
+    2013 ACC1 
+    2014 BRANCHIFNOT 2038
+    2016 ACC1 
+    2017 GETFIELD0 
+    2018 PUSHACC2 
+    2019 GETFIELD1 
+    2020 PUSHACC1 
+    2021 PUSHENVACC2 
+    2022 APPLY1 
+    2023 BRANCHIFNOT 2033
+    2025 ACC0 
+    2026 PUSHACC3 
+    2027 PUSHACC3 
+    2028 MAKEBLOCK2 0
+    2030 PUSHOFFSETCLOSURE0 
+    2031 APPTERM2 6
+    2033 ACC0 
+    2034 PUSHACC3 
+    2035 PUSHOFFSETCLOSURE0 
+    2036 APPTERM2 6
+    2038 ACC0 
+    2039 PUSHENVACC1 
+    2040 APPTERM1 3
+    2042 ACC0 
+    2043 PUSHENVACC1 
+    2044 CLOSUREREC 2, 2011
+    2048 CONST0 
+    2049 PUSHACC1 
+    2050 APPTERM1 3
+    2052 RESTART 
+    2053 GRAB 2
+    2055 ACC1 
+    2056 BRANCHIFNOT 2077
+    2058 ACC2 
+    2059 BRANCHIFNOT 2084
+    2061 ACC2 
+    2062 GETFIELD1 
+    2063 PUSHACC2 
+    2064 GETFIELD1 
+    2065 PUSHACC2 
+    2066 PUSHACC5 
+    2067 GETFIELD0 
+    2068 PUSHACC5 
+    2069 GETFIELD0 
+    2070 PUSHENVACC1 
+    2071 APPLY2 
+    2072 MAKEBLOCK2 0
+    2074 PUSHOFFSETCLOSURE0 
+    2075 APPTERM3 6
+    2077 ACC2 
+    2078 BRANCHIFNOT 2082
+    2080 BRANCH 2084
+    2082 RETURN 3
+    2084 GETGLOBAL "List.rev_map2"
+    2086 PUSHGETGLOBALFIELD Pervasives, 2
+    2089 APPTERM1 4
+    2091 RESTART 
+    2092 GRAB 2
+    2094 ACC0 
+    2095 CLOSUREREC 1, 2053
+    2099 ACC3 
+    2100 PUSHACC3 
+    2101 PUSHCONST0 
+    2102 PUSHACC3 
+    2103 APPTERM3 7
+    2105 RESTART 
+    2106 GRAB 1
+    2108 ACC1 
+    2109 BRANCHIFNOT 2123
+    2111 ACC1 
+    2112 GETFIELD1 
+    2113 PUSHACC1 
+    2114 PUSHACC3 
+    2115 GETFIELD0 
+    2116 PUSHENVACC1 
+    2117 APPLY1 
+    2118 MAKEBLOCK2 0
+    2120 PUSHOFFSETCLOSURE0 
+    2121 APPTERM2 4
+    2123 ACC0 
+    2124 RETURN 2
+    2126 RESTART 
+    2127 GRAB 1
+    2129 ACC0 
+    2130 CLOSUREREC 1, 2106
+    2134 ACC2 
+    2135 PUSHCONST0 
+    2136 PUSHACC2 
+    2137 APPTERM2 5
+    2139 CONST0 
+    2140 PUSHACC1 
+    2141 PUSHENVACC1 
+    2142 APPTERM2 3
+    2144 ACC0 
+    2145 BRANCHIFNOT 2151
+    2147 ACC0 
+    2148 GETFIELD1 
+    2149 RETURN 1
+    2151 GETGLOBAL "tl"
+    2153 PUSHGETGLOBALFIELD Pervasives, 3
+    2156 APPTERM1 2
+    2158 ACC0 
+    2159 BRANCHIFNOT 2165
+    2161 ACC0 
+    2162 GETFIELD0 
+    2163 RETURN 1
+    2165 GETGLOBAL "hd"
+    2167 PUSHGETGLOBALFIELD Pervasives, 3
+    2170 APPTERM1 2
+    2172 ACC0 
+    2173 PUSHCONST0 
+    2174 PUSHENVACC1 
+    2175 APPTERM2 3
+    2177 CLOSUREREC 0, 1200
+    2181 ACC0 
+    2182 CLOSURE 1, 2172
+    2185 PUSH 
+    2186 CLOSURE 0, 2158
+    2189 PUSH 
+    2190 CLOSURE 0, 2144
+    2193 PUSH 
+    2194 CLOSUREREC 0, 1217
+    2198 GETGLOBALFIELD Pervasives, 16
+    2201 PUSH 
+    2202 CLOSUREREC 0, 1259
+    2206 ACC0 
+    2207 CLOSURE 1, 2139
+    2210 PUSH 
+    2211 CLOSUREREC 0, 1277
+    2215 CLOSUREREC 0, 1294
+    2219 CLOSURE 0, 2127
+    2222 PUSH 
+    2223 CLOSUREREC 0, 1316
+    2227 CLOSUREREC 0, 1334
+    2231 CLOSUREREC 0, 1354
+    2235 CLOSUREREC 0, 1374
+    2239 CLOSURE 0, 2092
+    2242 PUSH 
+    2243 CLOSUREREC 0, 1415
+    2247 CLOSUREREC 0, 1452
+    2251 CLOSUREREC 0, 1490
+    2255 CLOSUREREC 0, 1530
+    2259 CLOSUREREC 0, 1553
+    2263 CLOSUREREC 0, 1573
+    2267 CLOSUREREC 0, 1613
+    2271 CLOSUREREC 0, 1654
+    2275 CLOSUREREC 0, 1675
+    2279 CLOSUREREC 0, 1695
+    2283 CLOSUREREC 0, 1725
+    2287 CLOSUREREC 0, 1754
+    2291 CLOSUREREC 0, 1776
+    2295 CLOSUREREC 0, 1797
+    2299 CLOSUREREC 0, 1828
+    2303 CLOSUREREC 0, 1858
+    2307 ACC 24
+    2309 CLOSURE 1, 2042
+    2312 PUSHACC 25
+    2314 CLOSUREREC 1, 1928
+    2318 CLOSUREREC 0, 1942
+    2322 CLOSUREREC 0, 1972
+    2326 ACC0 
+    2327 PUSHACC2 
+    2328 PUSHACC7 
+    2329 PUSHACC 9
+    2331 PUSHACC 11
+    2333 PUSHACC 13
+    2335 PUSHACC 15
+    2337 PUSHACC 17
+    2339 PUSHACC 10
+    2341 PUSHACC 12
+    2343 PUSHACC 13
+    2345 PUSHACC 15
+    2347 PUSHACC 23
+    2349 PUSHACC 25
+    2351 PUSHACC 27
+    2353 PUSHACC 29
+    2355 PUSHACC 31
+    2357 PUSHACC 33
+    2359 PUSHACC 35
+    2361 PUSHACC 37
+    2363 PUSHACC 40
+    2365 PUSHACC 42
+    2367 PUSHACC 41
+    2369 PUSHACC 45
+    2371 PUSHACC 47
+    2373 PUSHACC 50
+    2375 PUSHACC 52
+    2377 PUSHACC 51
+    2379 PUSHACC 55
+    2381 PUSHACC 56
+    2383 PUSHACC 59
+    2385 PUSHACC 61
+    2387 PUSHACC 60
+    2389 PUSHACC 64
+    2391 PUSHACC 66
+    2393 PUSHACC 68
+    2395 PUSHACC 70
+    2397 MAKEBLOCK 37, 0
+    2400 POP 36
+    2402 SETGLOBAL List
+    2404 BRANCH 2622
+    2406 CONSTINT 97
+    2408 PUSHACC1 
+    2409 GEINT 
+    2410 BRANCHIFNOT 2418
+    2412 CONSTINT 122
+    2414 PUSHACC1 
+    2415 LEINT 
+    2416 BRANCHIF 2442
+    2418 CONSTINT 224
+    2420 PUSHACC1 
+    2421 GEINT 
+    2422 BRANCHIFNOT 2430
+    2424 CONSTINT 246
+    2426 PUSHACC1 
+    2427 LEINT 
+    2428 BRANCHIF 2442
+    2430 CONSTINT 248
+    2432 PUSHACC1 
+    2433 GEINT 
+    2434 BRANCHIFNOT 2447
+    2436 CONSTINT 254
+    2438 PUSHACC1 
+    2439 LEINT 
+    2440 BRANCHIFNOT 2447
+    2442 ACC0 
+    2443 OFFSETINT -32
+    2445 RETURN 1
+    2447 ACC0 
+    2448 RETURN 1
+    2450 CONSTINT 65
+    2452 PUSHACC1 
+    2453 GEINT 
+    2454 BRANCHIFNOT 2462
+    2456 CONSTINT 90
+    2458 PUSHACC1 
+    2459 LEINT 
+    2460 BRANCHIF 2486
+    2462 CONSTINT 192
+    2464 PUSHACC1 
+    2465 GEINT 
+    2466 BRANCHIFNOT 2474
+    2468 CONSTINT 214
+    2470 PUSHACC1 
+    2471 LEINT 
+    2472 BRANCHIF 2486
+    2474 CONSTINT 216
+    2476 PUSHACC1 
+    2477 GEINT 
+    2478 BRANCHIFNOT 2491
+    2480 CONSTINT 222
+    2482 PUSHACC1 
+    2483 LEINT 
+    2484 BRANCHIFNOT 2491
+    2486 ACC0 
+    2487 OFFSETINT 32
+    2489 RETURN 1
+    2491 ACC0 
+    2492 RETURN 1
+    2494 CONSTINT 39
+    2496 PUSHACC1 
+    2497 LTINT 
+    2498 BRANCHIFNOT 2520
+    2500 CONSTINT 9
+    2502 PUSHACC1 
+    2503 EQ 
+    2504 BRANCHIFNOT 2510
+    2506 GETGLOBAL "\\t"
+    2508 RETURN 1
+    2510 CONSTINT 13
+    2512 PUSHACC1 
+    2513 EQ 
+    2514 BRANCHIFNOT 2540
+    2516 GETGLOBAL "\\n"
+    2518 RETURN 1
+    2520 CONSTINT 39
+    2522 PUSHACC1 
+    2523 EQ 
+    2524 BRANCHIFNOT 2530
+    2526 GETGLOBAL "\\'"
+    2528 RETURN 1
+    2530 CONSTINT 92
+    2532 PUSHACC1 
+    2533 EQ 
+    2534 BRANCHIFNOT 2540
+    2536 GETGLOBAL "\\\\"
+    2538 RETURN 1
+    2540 ACC0 
+    2541 C_CALL1 is_printable
+    2543 BRANCHIFNOT 2555
+    2545 CONST1 
+    2546 C_CALL1 create_string
+    2548 PUSHACC1 
+    2549 PUSHCONST0 
+    2550 PUSHACC2 
+    2551 SETSTRINGCHAR 
+    2552 ACC0 
+    2553 RETURN 2
+    2555 ACC0 
+    2556 PUSHCONSTINT 4
+    2558 C_CALL1 create_string
+    2560 PUSHCONSTINT 92
+    2562 PUSHCONST0 
+    2563 PUSHACC2 
+    2564 SETSTRINGCHAR 
+    2565 CONSTINT 100
+    2567 PUSHACC2 
+    2568 DIVINT 
+    2569 PUSHCONSTINT 48
+    2571 ADDINT 
+    2572 PUSHCONST1 
+    2573 PUSHACC2 
+    2574 SETSTRINGCHAR 
+    2575 CONSTINT 10
+    2577 PUSHCONSTINT 10
+    2579 PUSHACC3 
+    2580 DIVINT 
+    2581 MODINT 
+    2582 PUSHCONSTINT 48
+    2584 ADDINT 
+    2585 PUSHCONST2 
+    2586 PUSHACC2 
+    2587 SETSTRINGCHAR 
+    2588 CONSTINT 10
+    2590 PUSHACC2 
+    2591 MODINT 
+    2592 PUSHCONSTINT 48
+    2594 ADDINT 
+    2595 PUSHCONST3 
+    2596 PUSHACC2 
+    2597 SETSTRINGCHAR 
+    2598 ACC0 
+    2599 RETURN 3
+    2601 CONST0 
+    2602 PUSHACC1 
+    2603 LTINT 
+    2604 BRANCHIF 2612
+    2606 CONSTINT 255
+    2608 PUSHACC1 
+    2609 GTINT 
+    2610 BRANCHIFNOT 2619
+    2612 GETGLOBAL "Char.chr"
+    2614 PUSHGETGLOBALFIELD Pervasives, 2
+    2617 APPTERM1 2
+    2619 ACC0 
+    2620 RETURN 1
+    2622 CLOSURE 0, 2601
+    2625 PUSH 
+    2626 CLOSURE 0, 2494
+    2629 PUSH 
+    2630 CLOSURE 0, 2450
+    2633 PUSH 
+    2634 CLOSURE 0, 2406
+    2637 PUSHACC0 
+    2638 PUSHACC2 
+    2639 PUSHACC4 
+    2640 PUSHACC6 
+    2641 MAKEBLOCK 4, 0
+    2644 POP 4
+    2646 SETGLOBAL Char
+    2648 BRANCH 3540
+    2650 RESTART 
+    2651 GRAB 3
+    2653 ACC1 
+    2654 PUSHACC3 
+    2655 GEINT 
+    2656 BRANCHIFNOT 2663
+    2658 GETGLOBAL Not_found
+    2660 MAKEBLOCK1 0
+    2662 RAISE 
+    2663 ACC3 
+    2664 PUSHACC3 
+    2665 PUSHACC2 
+    2666 GETSTRINGCHAR 
+    2667 EQ 
+    2668 BRANCHIFNOT 2673
+    2670 ACC2 
+    2671 RETURN 4
+    2673 ACC3 
+    2674 PUSHACC3 
+    2675 OFFSETINT 1
+    2677 PUSHACC3 
+    2678 PUSHACC3 
+    2679 PUSHOFFSETCLOSURE0 
+    2680 APPTERM 4, 8
+    2683 RESTART 
+    2684 GRAB 2
+    2686 CONST0 
+    2687 PUSHACC2 
+    2688 LTINT 
+    2689 BRANCHIFNOT 2696
+    2691 GETGLOBAL Not_found
+    2693 MAKEBLOCK1 0
+    2695 RAISE 
+    2696 ACC2 
+    2697 PUSHACC2 
+    2698 PUSHACC2 
+    2699 GETSTRINGCHAR 
+    2700 EQ 
+    2701 BRANCHIFNOT 2706
+    2703 ACC1 
+    2704 RETURN 3
+    2706 ACC2 
+    2707 PUSHACC2 
+    2708 OFFSETINT -1
+    2710 PUSHACC2 
+    2711 PUSHOFFSETCLOSURE0 
+    2712 APPTERM3 6
+    2714 RESTART 
+    2715 GRAB 1
+    2717 ACC1 
+    2718 PUSHCONST0 
+    2719 PUSHACC2 
+    2720 PUSHENVACC1 
+    2721 APPTERM3 5
+    2723 RESTART 
+    2724 GRAB 2
+    2726 CONST0 
+    2727 PUSHACC2 
+    2728 LTINT 
+    2729 BRANCHIF 2738
+    2731 ACC0 
+    2732 C_CALL1 ml_string_length
+    2734 PUSHACC2 
+    2735 GEINT 
+    2736 BRANCHIFNOT 2745
+    2738 GETGLOBAL "String.rcontains_from"
+    2740 PUSHGETGLOBALFIELD Pervasives, 2
+    2743 APPTERM1 4
+    2745 PUSHTRAP 2756
+    2747 ACC6 
+    2748 PUSHACC6 
+    2749 PUSHACC6 
+    2750 PUSHENVACC1 
+    2751 APPLY3 
+    2752 CONST1 
+    2753 POPTRAP 
+    2754 RETURN 3
+    2756 PUSHGETGLOBAL Not_found
+    2758 PUSHACC1 
+    2759 GETFIELD0 
+    2760 EQ 
+    2761 BRANCHIFNOT 2766
+    2763 CONST0 
+    2764 RETURN 4
+    2766 ACC0 
+    2767 RAISE 
+    2768 RESTART 
+    2769 GRAB 2
+    2771 CONST0 
+    2772 PUSHACC2 
+    2773 LTINT 
+    2774 BRANCHIF 2783
+    2776 ACC0 
+    2777 C_CALL1 ml_string_length
+    2779 PUSHACC2 
+    2780 GTINT 
+    2781 BRANCHIFNOT 2790
+    2783 GETGLOBAL "String.contains_from"
+    2785 PUSHGETGLOBALFIELD Pervasives, 2
+    2788 APPTERM1 4
+    2790 PUSHTRAP 2811
+    2792 PUSH_RETADDR 2807
+    2794 ACC 9
+    2796 PUSHACC 9
+    2798 PUSHACC 9
+    2800 C_CALL1 ml_string_length
+    2802 PUSHACC 10
+    2804 PUSHENVACC1 
+    2805 APPLY 4
+    2807 CONST1 
+    2808 POPTRAP 
+    2809 RETURN 3
+    2811 PUSHGETGLOBAL Not_found
+    2813 PUSHACC1 
+    2814 GETFIELD0 
+    2815 EQ 
+    2816 BRANCHIFNOT 2821
+    2818 CONST0 
+    2819 RETURN 4
+    2821 ACC0 
+    2822 RAISE 
+    2823 RESTART 
+    2824 GRAB 2
+    2826 CONST0 
+    2827 PUSHACC2 
+    2828 LTINT 
+    2829 BRANCHIF 2838
+    2831 ACC0 
+    2832 C_CALL1 ml_string_length
+    2834 PUSHACC2 
+    2835 GEINT 
+    2836 BRANCHIFNOT 2845
+    2838 GETGLOBAL "String.rindex_from"
+    2840 PUSHGETGLOBALFIELD Pervasives, 2
+    2843 APPTERM1 4
+    2845 ACC2 
+    2846 PUSHACC2 
+    2847 PUSHACC2 
+    2848 PUSHENVACC1 
+    2849 APPTERM3 6
+    2851 RESTART 
+    2852 GRAB 1
+    2854 ACC1 
+    2855 PUSHACC1 
+    2856 C_CALL1 ml_string_length
+    2858 OFFSETINT -1
+    2860 PUSHACC2 
+    2861 PUSHENVACC1 
+    2862 APPTERM3 5
+    2864 RESTART 
+    2865 GRAB 2
+    2867 CONST0 
+    2868 PUSHACC2 
+    2869 LTINT 
+    2870 BRANCHIF 2879
+    2872 ACC0 
+    2873 C_CALL1 ml_string_length
+    2875 PUSHACC2 
+    2876 GTINT 
+    2877 BRANCHIFNOT 2886
+    2879 GETGLOBAL "String.index_from"
+    2881 PUSHGETGLOBALFIELD Pervasives, 2
+    2884 APPTERM1 4
+    2886 ACC2 
+    2887 PUSHACC2 
+    2888 PUSHACC2 
+    2889 C_CALL1 ml_string_length
+    2891 PUSHACC3 
+    2892 PUSHENVACC1 
+    2893 APPTERM 4, 7
+    2896 RESTART 
+    2897 GRAB 1
+    2899 ACC1 
+    2900 PUSHCONST0 
+    2901 PUSHACC2 
+    2902 C_CALL1 ml_string_length
+    2904 PUSHACC3 
+    2905 PUSHENVACC1 
+    2906 APPTERM 4, 6
+    2909 ACC0 
+    2910 PUSHGETGLOBALFIELD Char, 2
+    2913 PUSHENVACC1 
+    2914 APPTERM2 3
+    2916 ACC0 
+    2917 PUSHGETGLOBALFIELD Char, 3
+    2920 PUSHENVACC1 
+    2921 APPTERM2 3
+    2923 RESTART 
+    2924 GRAB 1
+    2926 CONST0 
+    2927 PUSHACC2 
+    2928 C_CALL1 ml_string_length
+    2930 EQ 
+    2931 BRANCHIFNOT 2936
+    2933 ACC1 
+    2934 RETURN 2
+    2936 ACC1 
+    2937 PUSHENVACC1 
+    2938 APPLY1 
+    2939 PUSHCONST0 
+    2940 PUSHACC3 
+    2941 GETSTRINGCHAR 
+    2942 PUSHACC2 
+    2943 APPLY1 
+    2944 PUSHCONST0 
+    2945 PUSHACC2 
+    2946 SETSTRINGCHAR 
+    2947 ACC0 
+    2948 RETURN 3
+    2950 ACC0 
+    2951 PUSHGETGLOBALFIELD Char, 2
+    2954 PUSHENVACC1 
+    2955 APPTERM2 3
+    2957 ACC0 
+    2958 PUSHGETGLOBALFIELD Char, 3
+    2961 PUSHENVACC1 
+    2962 APPTERM2 3
+    2964 RESTART 
+    2965 GRAB 1
+    2967 ACC1 
+    2968 C_CALL1 ml_string_length
+    2970 PUSHCONST0 
+    2971 PUSHACC1 
+    2972 EQ 
+    2973 BRANCHIFNOT 2978
+    2975 ACC2 
+    2976 RETURN 3
+    2978 ACC0 
+    2979 C_CALL1 create_string
+    2981 PUSHCONST0 
+    2982 PUSHACC2 
+    2983 OFFSETINT -1
+    2985 PUSH 
+    2986 BRANCH 3002
+    2988 CHECK_SIGNALS 
+    2989 ACC1 
+    2990 PUSHACC6 
+    2991 GETSTRINGCHAR 
+    2992 PUSHACC5 
+    2993 APPLY1 
+    2994 PUSHACC2 
+    2995 PUSHACC4 
+    2996 SETSTRINGCHAR 
+    2997 ACC1 
+    2998 OFFSETINT 1
+    3000 ASSIGN 1
+    3002 ACC0 
+    3003 PUSHACC2 
+    3004 LEINT 
+    3005 BRANCHIF 2988
+    3007 CONST0 
+    3008 POP 2
+    3010 ACC0 
+    3011 RETURN 4
+    3013 CONST0 
+    3014 PUSHCONST0 
+    3015 PUSHACC2 
+    3016 C_CALL1 ml_string_length
+    3018 OFFSETINT -1
+    3020 PUSH 
+    3021 BRANCH 3059
+    3023 CHECK_SIGNALS 
+    3024 ACC1 
+    3025 PUSHACC4 
+    3026 GETSTRINGCHAR 
+    3027 PUSHACC0 
+    3028 PUSHGETGLOBAL "\000\"\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
+    3030 C_CALL2 bitvect_test
+    3032 BRANCHIFNOT 3038
+    3034 CONST0 
+    3035 CONST2 
+    3036 BRANCH 3048
+    3038 ACC0 
+    3039 C_CALL1 is_printable
+    3041 BRANCHIFNOT 3046
+    3043 CONST1 
+    3044 BRANCH 3048
+    3046 CONSTINT 4
+    3048 POP 1
+    3050 PUSHACC3 
+    3051 ADDINT 
+    3052 ASSIGN 2
+    3054 ACC1 
+    3055 OFFSETINT 1
+    3057 ASSIGN 1
+    3059 ACC0 
+    3060 PUSHACC2 
+    3061 LEINT 
+    3062 BRANCHIF 3023
+    3064 CONST0 
+    3065 POP 2
+    3067 ACC1 
+    3068 C_CALL1 ml_string_length
+    3070 PUSHACC1 
+    3071 EQ 
+    3072 BRANCHIFNOT 3077
+    3074 ACC1 
+    3075 RETURN 2
+    3077 ACC0 
+    3078 C_CALL1 create_string
+    3080 PUSHCONST0 
+    3081 ASSIGN 1
+    3083 CONST0 
+    3084 PUSHACC3 
+    3085 C_CALL1 ml_string_length
+    3087 OFFSETINT -1
+    3089 PUSH 
+    3090 BRANCH 3245
+    3092 CHECK_SIGNALS 
+    3093 ACC1 
+    3094 PUSHACC5 
+    3095 GETSTRINGCHAR 
+    3096 PUSHACC0 
+    3097 PUSHGETGLOBAL "\000\000\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
+    3099 C_CALL2 bitvect_test
+    3101 BRANCHIFNOT 3120
+    3103 CONST0 
+    3104 CONSTINT 92
+    3106 PUSHACC5 
+    3107 PUSHACC5 
+    3108 SETSTRINGCHAR 
+    3109 ACC4 
+    3110 OFFSETINT 1
+    3112 ASSIGN 4
+    3114 ACC0 
+    3115 PUSHACC5 
+    3116 PUSHACC5 
+    3117 SETSTRINGCHAR 
+    3118 BRANCH 3233
+    3120 CONSTINT 9
+    3122 PUSHACC1 
+    3123 EQ 
+    3124 BRANCHIFNOT 3143
+    3126 CONSTINT 92
+    3128 PUSHACC5 
+    3129 PUSHACC5 
+    3130 SETSTRINGCHAR 
+    3131 ACC4 
+    3132 OFFSETINT 1
+    3134 ASSIGN 4
+    3136 CONSTINT 116
+    3138 PUSHACC5 
+    3139 PUSHACC5 
+    3140 SETSTRINGCHAR 
+    3141 BRANCH 3233
+    3143 CONSTINT 13
+    3145 PUSHACC1 
+    3146 EQ 
+    3147 BRANCHIFNOT 3166
+    3149 CONSTINT 92
+    3151 PUSHACC5 
+    3152 PUSHACC5 
+    3153 SETSTRINGCHAR 
+    3154 ACC4 
+    3155 OFFSETINT 1
+    3157 ASSIGN 4
+    3159 CONSTINT 110
+    3161 PUSHACC5 
+    3162 PUSHACC5 
+    3163 SETSTRINGCHAR 
+    3164 BRANCH 3233
+    3166 ACC0 
+    3167 C_CALL1 is_printable
+    3169 BRANCHIFNOT 3177
+    3171 ACC0 
+    3172 PUSHACC5 
+    3173 PUSHACC5 
+    3174 SETSTRINGCHAR 
+    3175 BRANCH 3233
+    3177 ACC0 
+    3178 PUSHCONSTINT 92
+    3180 PUSHACC6 
+    3181 PUSHACC6 
+    3182 SETSTRINGCHAR 
+    3183 ACC5 
+    3184 OFFSETINT 1
+    3186 ASSIGN 5
+    3188 CONSTINT 100
+    3190 PUSHACC1 
+    3191 DIVINT 
+    3192 PUSHCONSTINT 48
+    3194 ADDINT 
+    3195 PUSHACC6 
+    3196 PUSHACC6 
+    3197 SETSTRINGCHAR 
+    3198 ACC5 
+    3199 OFFSETINT 1
+    3201 ASSIGN 5
+    3203 CONSTINT 10
+    3205 PUSHCONSTINT 10
+    3207 PUSHACC2 
+    3208 DIVINT 
+    3209 MODINT 
+    3210 PUSHCONSTINT 48
+    3212 ADDINT 
+    3213 PUSHACC6 
+    3214 PUSHACC6 
+    3215 SETSTRINGCHAR 
+    3216 ACC5 
+    3217 OFFSETINT 1
+    3219 ASSIGN 5
+    3221 CONSTINT 10
+    3223 PUSHACC1 
+    3224 MODINT 
+    3225 PUSHCONSTINT 48
+    3227 ADDINT 
+    3228 PUSHACC6 
+    3229 PUSHACC6 
+    3230 SETSTRINGCHAR 
+    3231 POP 1
+    3233 POP 1
+    3235 ACC3 
+    3236 OFFSETINT 1
+    3238 ASSIGN 3
+    3240 ACC1 
+    3241 OFFSETINT 1
+    3243 ASSIGN 1
+    3245 ACC0 
+    3246 PUSHACC2 
+    3247 LEINT 
+    3248 BRANCHIF 3092
+    3250 CONST0 
+    3251 POP 2
+    3253 ACC0 
+    3254 RETURN 3
+    3256 ENVACC1 
+    3257 C_CALL1 ml_string_length
+    3259 PUSHENVACC3 
+    3260 GETFIELD0 
+    3261 PUSHENVACC2 
+    3262 PUSHCONST0 
+    3263 PUSHENVACC1 
+    3264 C_CALL5 blit_string
+    3266 ENVACC1 
+    3267 C_CALL1 ml_string_length
+    3269 PUSHENVACC3 
+    3270 GETFIELD0 
+    3271 ADDINT 
+    3272 PUSHENVACC3 
+    3273 SETFIELD0 
+    3274 ACC0 
+    3275 C_CALL1 ml_string_length
+    3277 PUSHENVACC3 
+    3278 GETFIELD0 
+    3279 PUSHENVACC2 
+    3280 PUSHCONST0 
+    3281 PUSHACC4 
+    3282 C_CALL5 blit_string
+    3284 ACC0 
+    3285 C_CALL1 ml_string_length
+    3287 PUSHENVACC3 
+    3288 GETFIELD0 
+    3289 ADDINT 
+    3290 PUSHENVACC3 
+    3291 SETFIELD0 
+    3292 RETURN 1
+    3294 ENVACC1 
+    3295 OFFSETREF 1
+    3297 ACC0 
+    3298 C_CALL1 ml_string_length
+    3300 PUSHENVACC2 
+    3301 GETFIELD0 
+    3302 ADDINT 
+    3303 PUSHENVACC2 
+    3304 SETFIELD0 
+    3305 RETURN 1
+    3307 RESTART 
+    3308 GRAB 1
+    3310 ACC1 
+    3311 BRANCHIFNOT 3374
+    3313 ACC1 
+    3314 GETFIELD0 
+    3315 PUSHCONST0 
+    3316 MAKEBLOCK1 0
+    3318 PUSHCONST0 
+    3319 MAKEBLOCK1 0
+    3321 PUSHACC4 
+    3322 PUSHACC1 
+    3323 PUSHACC3 
+    3324 CLOSURE 2, 3294
+    3327 PUSHGETGLOBALFIELD List, 9
+    3330 APPLY2 
+    3331 ACC1 
+    3332 GETFIELD0 
+    3333 OFFSETINT -1
+    3335 PUSHACC4 
+    3336 C_CALL1 ml_string_length
+    3338 MULINT 
+    3339 PUSHACC1 
+    3340 GETFIELD0 
+    3341 ADDINT 
+    3342 C_CALL1 create_string
+    3344 PUSHACC3 
+    3345 C_CALL1 ml_string_length
+    3347 PUSHCONST0 
+    3348 PUSHACC2 
+    3349 PUSHCONST0 
+    3350 PUSHACC7 
+    3351 C_CALL5 blit_string
+    3353 ACC3 
+    3354 C_CALL1 ml_string_length
+    3356 MAKEBLOCK1 0
+    3358 PUSHACC6 
+    3359 GETFIELD1 
+    3360 PUSHACC1 
+    3361 PUSHACC3 
+    3362 PUSHACC 8
+    3364 CLOSURE 3, 3256
+    3367 PUSHGETGLOBALFIELD List, 9
+    3370 APPLY2 
+    3371 ACC1 
+    3372 RETURN 7
+    3374 GETGLOBAL ""
+    3376 RETURN 2
+    3378 RESTART 
+    3379 GRAB 4
+    3381 CONST0 
+    3382 PUSHACC5 
+    3383 LTINT 
+    3384 BRANCHIF 3414
+    3386 CONST0 
+    3387 PUSHACC2 
+    3388 LTINT 
+    3389 BRANCHIF 3414
+    3391 ACC0 
+    3392 C_CALL1 ml_string_length
+    3394 PUSHACC5 
+    3395 PUSHACC3 
+    3396 ADDINT 
+    3397 GTINT 
+    3398 BRANCHIF 3414
+    3400 CONST0 
+    3401 PUSHACC4 
+    3402 LTINT 
+    3403 BRANCHIF 3414
+    3405 ACC2 
+    3406 C_CALL1 ml_string_length
+    3408 PUSHACC5 
+    3409 PUSHACC5 
+    3410 ADDINT 
+    3411 GTINT 
+    3412 BRANCHIFNOT 3421
+    3414 GETGLOBAL "String.blit"
+    3416 PUSHGETGLOBALFIELD Pervasives, 2
+    3419 APPTERM1 6
+    3421 ACC4 
+    3422 PUSHACC4 
+    3423 PUSHACC4 
+    3424 PUSHACC4 
+    3425 PUSHACC4 
+    3426 C_CALL5 blit_string
+    3428 RETURN 5
+    3430 RESTART 
+    3431 GRAB 3
+    3433 CONST0 
+    3434 PUSHACC2 
+    3435 LTINT 
+    3436 BRANCHIF 3452
+    3438 CONST0 
+    3439 PUSHACC3 
+    3440 LTINT 
+    3441 BRANCHIF 3452
+    3443 ACC0 
+    3444 C_CALL1 ml_string_length
+    3446 PUSHACC3 
+    3447 PUSHACC3 
+    3448 ADDINT 
+    3449 GTINT 
+    3450 BRANCHIFNOT 3459
+    3452 GETGLOBAL "String.fill"
+    3454 PUSHGETGLOBALFIELD Pervasives, 2
+    3457 APPTERM1 5
+    3459 ACC3 
+    3460 PUSHACC3 
+    3461 PUSHACC3 
+    3462 PUSHACC3 
+    3463 C_CALL4 fill_string
+    3465 RETURN 4
+    3467 RESTART 
+    3468 GRAB 2
+    3470 CONST0 
+    3471 PUSHACC2 
+    3472 LTINT 
+    3473 BRANCHIF 3489
+    3475 CONST0 
+    3476 PUSHACC3 
+    3477 LTINT 
+    3478 BRANCHIF 3489
+    3480 ACC0 
+    3481 C_CALL1 ml_string_length
+    3483 PUSHACC3 
+    3484 PUSHACC3 
+    3485 ADDINT 
+    3486 GTINT 
+    3487 BRANCHIFNOT 3496
+    3489 GETGLOBAL "String.sub"
+    3491 PUSHGETGLOBALFIELD Pervasives, 2
+    3494 APPTERM1 4
+    3496 ACC2 
+    3497 C_CALL1 create_string
+    3499 PUSHACC3 
+    3500 PUSHCONST0 
+    3501 PUSHACC2 
+    3502 PUSHACC5 
+    3503 PUSHACC5 
+    3504 C_CALL5 blit_string
+    3506 ACC0 
+    3507 RETURN 4
+    3509 ACC0 
+    3510 C_CALL1 ml_string_length
+    3512 PUSHACC0 
+    3513 C_CALL1 create_string
+    3515 PUSHACC1 
+    3516 PUSHCONST0 
+    3517 PUSHACC2 
+    3518 PUSHCONST0 
+    3519 PUSHACC6 
+    3520 C_CALL5 blit_string
+    3522 ACC0 
+    3523 RETURN 3
+    3525 RESTART 
+    3526 GRAB 1
+    3528 ACC0 
+    3529 C_CALL1 create_string
+    3531 PUSHACC2 
+    3532 PUSHACC2 
+    3533 PUSHCONST0 
+    3534 PUSHACC3 
+    3535 C_CALL4 fill_string
+    3537 ACC0 
+    3538 RETURN 3
+    3540 CLOSURE 0, 3526
+    3543 PUSH 
+    3544 CLOSURE 0, 3509
+    3547 PUSH 
+    3548 CLOSURE 0, 3468
+    3551 PUSH 
+    3552 CLOSURE 0, 3431
+    3555 PUSH 
+    3556 CLOSURE 0, 3379
+    3559 PUSH 
+    3560 CLOSURE 0, 3308
+    3563 PUSH 
+    3564 CLOSURE 0, 3013
+    3567 PUSH 
+    3568 CLOSURE 0, 2965
+    3571 PUSHACC0 
+    3572 CLOSURE 1, 2957
+    3575 PUSHACC1 
+    3576 CLOSURE 1, 2950
+    3579 PUSHACC 8
+    3581 CLOSURE 1, 2924
+    3584 PUSHACC0 
+    3585 CLOSURE 1, 2916
+    3588 PUSHACC1 
+    3589 CLOSURE 1, 2909
+    3592 PUSH 
+    3593 CLOSUREREC 0, 2651
+    3597 ACC0 
+    3598 CLOSURE 1, 2897
+    3601 PUSHACC1 
+    3602 CLOSURE 1, 2865
+    3605 PUSH 
+    3606 CLOSUREREC 0, 2684
+    3610 ACC0 
+    3611 CLOSURE 1, 2852
+    3614 PUSHACC1 
+    3615 CLOSURE 1, 2824
+    3618 PUSHACC5 
+    3619 CLOSURE 1, 2769
+    3622 PUSHACC3 
+    3623 CLOSURE 1, 2724
+    3626 PUSHACC1 
+    3627 CLOSURE 1, 2715
+    3630 PUSHACC 9
+    3632 PUSHACC 11
+    3634 PUSHACC 14
+    3636 PUSHACC 16
+    3638 PUSHACC5 
+    3639 PUSHACC7 
+    3640 PUSHACC6 
+    3641 PUSHACC 10
+    3643 PUSHACC 14
+    3645 PUSHACC 13
+    3647 PUSHACC 17
+    3649 PUSHACC 26
+    3651 PUSHACC 28
+    3653 PUSHACC 30
+    3655 PUSHACC 32
+    3657 PUSHACC 34
+    3659 PUSHACC 36
+    3661 PUSHACC 38
+    3663 MAKEBLOCK 18, 0
+    3666 POP 22
+    3668 SETGLOBAL String
+    3670 CONST0 
+    3671 C_CALL1 gc_stat
+    3673 GETGLOBAL ""
+    3675 PUSHCONSTINT 20
+    3677 C_CALL2 make_vect
+    3679 PUSHCONSTINT 20
+    3681 C_CALL1 weak_create
+    3683 PUSHCONST0 
+    3684 PUSHCONSTINT 19
+    3686 PUSH 
+    3687 BRANCH 3715
+    3689 CHECK_SIGNALS 
+    3690 CONSTINT 115
+    3692 PUSHCONSTINT 20
+    3694 PUSHGETGLOBALFIELD String, 0
+    3697 APPLY2 
+    3698 PUSHACC2 
+    3699 PUSHACC5 
+    3700 SETVECTITEM 
+    3701 ACC1 
+    3702 PUSHACC4 
+    3703 GETVECTITEM 
+    3704 MAKEBLOCK1 0
+    3706 PUSHACC2 
+    3707 PUSHACC4 
+    3708 C_CALL3 weak_set
+    3710 ACC1 
+    3711 OFFSETINT 1
+    3713 ASSIGN 1
+    3715 ACC0 
+    3716 PUSHACC2 
+    3717 LEINT 
+    3718 BRANCHIF 3689
+    3720 CONST0 
+    3721 POP 2
+    3723 CONST0 
+    3724 C_CALL1 gc_full_major
+    3726 CONST0 
+    3727 PUSHCONSTINT 19
+    3729 PUSH 
+    3730 BRANCH 3753
+    3732 CHECK_SIGNALS 
+    3733 ACC1 
+    3734 PUSHACC3 
+    3735 C_CALL2 weak_get
+    3737 PUSHACC0 
+    3738 BRANCHIF 3745
+    3740 GETGLOBAL Not_found
+    3742 MAKEBLOCK1 0
+    3744 RAISE 
+    3745 CONST0 
+    3746 POP 1
+    3748 ACC1 
+    3749 OFFSETINT 1
+    3751 ASSIGN 1
+    3753 ACC0 
+    3754 PUSHACC2 
+    3755 LEINT 
+    3756 BRANCHIF 3732
+    3758 CONST0 
+    3759 POP 2
+    3761 CONST0 
+    3762 PUSHCONSTINT 19
+    3764 PUSH 
+    3765 BRANCH 3785
+    3767 CHECK_SIGNALS 
+    3768 CONST0 
+    3769 PUSHCONST2 
+    3770 PUSHACC3 
+    3771 MODINT 
+    3772 EQ 
+    3773 BRANCHIFNOT 3780
+    3775 GETGLOBAL ""
+    3777 PUSHACC2 
+    3778 PUSHACC5 
+    3779 SETVECTITEM 
+    3780 ACC1 
+    3781 OFFSETINT 1
+    3783 ASSIGN 1
+    3785 ACC0 
+    3786 PUSHACC2 
+    3787 LEINT 
+    3788 BRANCHIF 3767
+    3790 CONST0 
+    3791 POP 2
+    3793 CONST0 
+    3794 C_CALL1 gc_full_major
+    3796 CONST0 
+    3797 PUSHCONSTINT 19
+    3799 PUSH 
+    3800 BRANCH 3854
+    3802 CHECK_SIGNALS 
+    3803 ACC1 
+    3804 PUSHACC3 
+    3805 C_CALL2 weak_get
+    3807 PUSHACC0 
+    3808 BRANCHIFNOT 3832
+    3810 CONST1 
+    3811 PUSHCONST2 
+    3812 PUSHACC4 
+    3813 MODINT 
+    3814 EQ 
+    3815 BRANCHIFNOT 3842
+    3817 CONSTINT 115
+    3819 PUSHCONSTINT 5
+    3821 PUSHACC2 
+    3822 GETFIELD0 
+    3823 GETSTRINGCHAR 
+    3824 NEQ 
+    3825 BRANCHIFNOT 3847
+    3827 GETGLOBAL Not_found
+    3829 MAKEBLOCK1 0
+    3831 RAISE 
+    3832 CONST0 
+    3833 PUSHCONST2 
+    3834 PUSHACC4 
+    3835 MODINT 
+    3836 EQ 
+    3837 BRANCHIFNOT 3842
+    3839 CONST0 
+    3840 BRANCH 3847
+    3842 GETGLOBAL Not_found
+    3844 MAKEBLOCK1 0
+    3846 RAISE 
+    3847 POP 1
+    3849 ACC1 
+    3850 OFFSETINT 1
+    3852 ASSIGN 1
+    3854 ACC0 
+    3855 PUSHACC2 
+    3856 LEINT 
+    3857 BRANCHIF 3802
+    3859 CONST0 
+    3860 POP 4
+    3862 ATOM0 
+    3863 SETGLOBAL T350-heapcheck
+    3865 STOP 
+**)
diff --git a/test/testinterp/t360-stacks-1.ml b/test/testinterp/t360-stacks-1.ml
new file mode 100644
index 00000000..100fbabb
--- /dev/null
+++ b/test/testinterp/t360-stacks-1.ml
@@ -0,0 +1,43 @@
+open Lib;;
+let rec f n =
+  if n <= 0 then 12
+  else 1 + f (n-1)
+in
+if f 30000 <> 30012 then raise Not_found
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 29
+      11 CONST0 
+      12 PUSHACC1 
+      13 LEINT 
+      14 BRANCHIFNOT 20
+      16 CONSTINT 12
+      18 RETURN 1
+      20 ACC0 
+      21 OFFSETINT -1
+      23 PUSHOFFSETCLOSURE0 
+      24 APPLY1 
+      25 PUSHCONST1 
+      26 ADDINT 
+      27 RETURN 1
+      29 CLOSUREREC 0, 11
+      33 CONSTINT 30012
+      35 PUSHCONSTINT 30000
+      37 PUSHACC2 
+      38 APPLY1 
+      39 NEQ 
+      40 BRANCHIFNOT 47
+      42 GETGLOBAL Not_found
+      44 MAKEBLOCK1 0
+      46 RAISE 
+      47 POP 1
+      49 ATOM0 
+      50 SETGLOBAL T360-stacks-1
+      52 STOP 
+**)
diff --git a/test/testinterp/t360-stacks-2.ml b/test/testinterp/t360-stacks-2.ml
new file mode 100644
index 00000000..8d13c7d7
--- /dev/null
+++ b/test/testinterp/t360-stacks-2.ml
@@ -0,0 +1,54 @@
+open Lib;;
+let rec f n =
+  if n <= 0 then 12
+  else 1 + f (n-1)
+in
+try
+  ignore (f 3000000);
+  raise Not_found
+with Stack_overflow -> ()
+;;
+
+(**
+       0 CONSTINT 42
+       2 PUSHACC0 
+       3 MAKEBLOCK1 0
+       5 POP 1
+       7 SETGLOBAL Lib
+       9 BRANCH 29
+      11 CONST0 
+      12 PUSHACC1 
+      13 LEINT 
+      14 BRANCHIFNOT 20
+      16 CONSTINT 12
+      18 RETURN 1
+      20 ACC0 
+      21 OFFSETINT -1
+      23 PUSHOFFSETCLOSURE0 
+      24 APPLY1 
+      25 PUSHCONST1 
+      26 ADDINT 
+      27 RETURN 1
+      29 CLOSUREREC 0, 11
+      33 PUSHTRAP 44
+      35 CONSTINT 3000000
+      37 PUSHACC5 
+      38 APPLY1 
+      39 GETGLOBAL Not_found
+      41 MAKEBLOCK1 0
+      43 RAISE 
+      44 PUSHGETGLOBAL Stack_overflow
+      46 PUSHACC1 
+      47 GETFIELD0 
+      48 EQ 
+      49 BRANCHIFNOT 54
+      51 CONST0 
+      52 BRANCH 56
+      54 ACC0 
+      55 RAISE 
+      56 POP 1
+      58 POP 1
+      60 ATOM0 
+      61 SETGLOBAL T360-stacks-2
+      63 STOP 
+**)
diff --git a/testasmcomp/.cvsignore b/testasmcomp/.cvsignore
new file mode 100644
index 00000000..76174b53
--- /dev/null
+++ b/testasmcomp/.cvsignore
@@ -0,0 +1,5 @@
+codegen
+parsecmm.ml
+parsecmm.mli
+lexcmm.ml
+*.out
diff --git a/testasmcomp/.depend b/testasmcomp/.depend
new file mode 100644
index 00000000..282114bc
--- /dev/null
+++ b/testasmcomp/.depend
@@ -0,0 +1,17 @@
+lexcmm.cmi: parsecmm.cmi 
+parsecmm.cmi: ../asmcomp/cmm.cmi 
+parsecmmaux.cmi: ../typing/ident.cmi 
+lexcmm.cmo: ../utils/misc.cmi parsecmm.cmi lexcmm.cmi 
+lexcmm.cmx: ../utils/misc.cmx parsecmm.cmx lexcmm.cmi 
+main.cmo: ../asmcomp/asmgen.cmi ../utils/clflags.cmo ../asmcomp/compilenv.cmi \
+    ../asmcomp/emit.cmi lexcmm.cmi parsecmm.cmi parsecmmaux.cmi \
+    ../asmcomp/printmach.cmi 
+main.cmx: ../asmcomp/asmgen.cmx ../utils/clflags.cmx ../asmcomp/compilenv.cmx \
+    ../asmcomp/emit.cmx lexcmm.cmx parsecmm.cmx parsecmmaux.cmx \
+    ../asmcomp/printmach.cmx 
+parsecmm.cmo: ../asmcomp/arch.cmo ../asmcomp/cmm.cmi ../utils/misc.cmi \
+    parsecmmaux.cmi parsecmm.cmi 
+parsecmm.cmx: ../asmcomp/arch.cmx ../asmcomp/cmm.cmx ../utils/misc.cmx \
+    parsecmmaux.cmx parsecmm.cmi 
+parsecmmaux.cmo: ../typing/ident.cmi parsecmmaux.cmi 
+parsecmmaux.cmx: ../typing/ident.cmx parsecmmaux.cmi 
diff --git a/testasmcomp/Makefile b/testasmcomp/Makefile
new file mode 100644
index 00000000..28fc7cc3
--- /dev/null
+++ b/testasmcomp/Makefile
@@ -0,0 +1,159 @@
+#########################################################################
+#                                                                       #
+#                            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.33 2003/06/30 08:28:46 xleroy Exp $
+
+include ../config/Makefile
+
+CAMLC=../boot/ocamlrun ../boot/ocamlc -I ../boot
+COMPFLAGS=$(INCLUDES) -g
+LINKFLAGS=-g
+CAMLYACC=../boot/ocamlyacc
+YACCFLAGS=
+CAMLLEX=../boot/ocamlrun ../boot/ocamllex
+CAMLDEP=../boot/ocamlrun ../tools/ocamldep
+DEPFLAGS=$(INCLUDES)
+CAMLRUN=../boot/ocamlrun
+
+CODEGEN=./codegen
+CC=$(NATIVECC)
+CFLAGS=$(NATIVECCCOMPOPTS) -g
+
+PROGS=fib.out tak.out quicksort.out quicksort2.out soli.out integr.out \
+      arith.out checkbound.out
+
+all: codegen $(PROGS)
+
+INCLUDES=-I ../utils -I ../typing -I ../asmcomp
+
+OTHEROBJS=../utils/misc.cmo ../utils/config.cmo ../utils/tbl.cmo \
+  ../utils/clflags.cmo ../utils/ccomp.cmo \
+  ../utils/config.cmo ../utils/clflags.cmo ../utils/warnings.cmo \
+  ../utils/consistbl.cmo \
+  ../parsing/linenum.cmo ../parsing/location.cmo \
+  ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \
+  ../typing/btype.cmo ../typing/subst.cmo ../typing/primitive.cmo \
+  ../typing/predef.cmo ../typing/datarepr.cmo ../typing/env.cmo \
+  ../bytecomp/lambda.cmo ../bytecomp/switch.cmo \
+  ../asmcomp/arch.cmo ../asmcomp/cmm.cmo ../asmcomp/printcmm.cmo \
+  ../asmcomp/clambda.cmo ../asmcomp/compilenv.cmo \
+  ../asmcomp/reg.cmo ../asmcomp/mach.cmo ../asmcomp/proc.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/linearize.cmo ../asmcomp/schedgen.cmo ../asmcomp/scheduling.cmo \
+  ../asmcomp/printlinear.cmo ../asmcomp/emitaux.cmo \
+  ../asmcomp/emit.cmo ../asmcomp/asmgen.cmo
+
+OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo main.cmo
+
+codegen: $(OTHEROBJS) $(OBJS)
+	$(CAMLC) $(LINKFLAGS) -o codegen $(OTHEROBJS) $(OBJS)
+clean::
+	rm -f codegen
+
+# The parser
+
+parsecmm.mli parsecmm.ml: parsecmm.mly
+	$(CAMLYACC) $(YACCFLAGS) parsecmm.mly
+
+clean::
+	rm -f parsecmm.mli parsecmm.ml parsecmm.output
+
+beforedepend:: parsecmm.mli parsecmm.ml
+
+# The lexer
+
+lexcmm.ml: lexcmm.mll
+	$(CAMLLEX) lexcmm.mll
+
+clean::
+	rm -f lexcmm.ml
+
+beforedepend:: lexcmm.ml
+
+# The test programs
+
+$(PROGS:.out=.o): codegen
+
+fib.out: main.c fib.o $(ARCH).o
+	$(CC) $(CFLAGS) -o fib.out -DINT_INT -DFUN=fib main.c fib.o $(ARCH).o
+
+tak.out: main.c tak.o $(ARCH).o
+	$(CC) $(CFLAGS) -o tak.out -DUNIT_INT -DFUN=takmain main.c tak.o $(ARCH).o
+
+quicksort.out: main.c quicksort.o $(ARCH).o
+	$(CC) $(CFLAGS) -o quicksort.out -DSORT -DFUN=quicksort main.c quicksort.o $(ARCH).o
+
+quicksort2.out: main.c quicksort2.o $(ARCH).o
+	$(CC) $(CFLAGS) -o quicksort2.out -DSORT -DFUN=quicksort main.c quicksort2.o $(ARCH).o
+
+soli.out: main.c soli.o $(ARCH).o
+	$(CC) $(CFLAGS) -o soli.out -DUNIT_INT -DFUN=solitaire main.c soli.o $(ARCH).o
+
+integr.out: main.c integr.o $(ARCH).o
+	$(CC) $(CFLAGS) -o integr.out -DINT_FLOAT -DFUN=test main.c integr.o $(ARCH).o
+
+tagged-fib.out: main.c tagged-fib.o $(ARCH).o
+	$(CC) $(CFLAGS) -o tagged-fib.out -DINT_INT -DFUN=fib main.c tagged-fib.o $(ARCH).o
+
+tagged-tak.out: main.c tagged-tak.o $(ARCH).o
+	$(CC) $(CFLAGS) -o tagged-tak.out -DUNIT_INT -DFUN=takmain main.c tagged-tak.o $(ARCH).o
+
+tagged-quicksort.out: main.c tagged-quicksort.o $(ARCH).o
+	$(CC) $(CFLAGS) -o tagged-quicksort.out -DSORT -DFUN=quicksort main.c tagged-quicksort.o $(ARCH).o
+
+tagged-integr.out: main.c tagged-integr.o $(ARCH).o
+	$(CC) $(CFLAGS) -o tagged-integr.out -DINT_FLOAT -DFUN=test main.c tagged-integr.o $(ARCH).o
+
+arith.out: mainarith.c arith.o $(ARCH).o
+	$(CC) $(CFLAGS) -o arith.out mainarith.c arith.o $(ARCH).o
+
+checkbound.out: main.c checkbound.o $(ARCH).o
+	$(CC) $(CFLAGS) -o checkbound.out -DCHECKBOUND main.c checkbound.o $(ARCH).o
+
+# The runtime environment
+
+power.o: power-$(SYSTEM).o
+	cp power-$(SYSTEM).o power.o
+
+.SUFFIXES:
+.SUFFIXES: .cmm .c .o .S .ml .mli .cmo .cmi .s
+
+.ml.cmo:
+	$(CAMLC) $(COMPFLAGS) -c $<
+
+.mli.cmi:
+	$(CAMLC) $(COMPFLAGS) -c $<
+
+.cmm.o:
+	$(CAMLRUN) $(CODEGEN) $*.cmm > $*.s
+	$(AS) $(ASFLAGS) -o $*.o $*.s
+
+.S.o:
+	$(ASPP) $(ASPPFLAGS) -o $*.o $*.S
+
+.s.o:
+	$(ASPP) $(ASPPFLAGS) -o $*.o $*.s
+
+clean::
+	rm -f *.out *.cm[io] *.s *.o *~
+
+$(PROGS:.out=.o): $(CODEGEN)
+
+depend: beforedepend
+	$(CAMLDEP) $(DEPFLAGS) *.mli *.ml > .depend
+
+include .depend
diff --git a/testasmcomp/alpha.S b/testasmcomp/alpha.S
new file mode 100644
index 00000000..bb7a9593
--- /dev/null
+++ b/testasmcomp/alpha.S
@@ -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 Q Public License version 1.0.               */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id: alpha.S,v 1.4 1999/11/29 19:04:18 doligez Exp $ */
+
+        .globl  call_gen_code
+        .ent    call_gen_code
+
+call_gen_code:
+        lda     $sp, -80($sp)
+        stq     $26, 0($sp)
+        stq     $9, 8($sp)
+        stq     $10, 16($sp)
+        stq     $11, 24($sp)
+        stq     $12, 32($sp)
+        stt     $f2, 40($sp)
+        stt     $f3, 48($sp)
+        stt     $f4, 56($sp)
+        stt     $f5, 64($sp)
+        mov     $16, $27
+        mov     $17, $16
+        mov     $18, $17
+        mov     $19, $18
+        mov     $20, $19
+        jsr     ($27)
+        ldq     $26, 0($sp)
+        ldq     $9, 8($sp)
+        ldq     $10, 16($sp)
+        ldq     $11, 24($sp)
+        ldq     $12, 32($sp)
+        ldt     $f2, 40($sp)
+        ldt     $f3, 48($sp)
+        ldt     $f4, 56($sp)
+        ldt     $f5, 64($sp)
+        lda     $sp, 80($sp)
+        ret     ($26)
+
+        .end    call_gen_code
+
+        .globl  caml_c_call
+        .ent    caml_c_call
+caml_c_call:
+        lda     $sp, -16($sp)
+        stq     $26, 0($sp)
+        stq     $gp, 8($sp)
+        mov     $25, $27
+        jsr     ($25)
+        ldq     $26, 0($sp)
+        ldq     $gp, 8($sp)
+        lda     $sp, 16($sp)
+        ret     ($26)
+
+        .end    caml_c_call
diff --git a/testasmcomp/amd64.S b/testasmcomp/amd64.S
new file mode 100644
index 00000000..e4f943c4
--- /dev/null
+++ b/testasmcomp/amd64.S
@@ -0,0 +1,53 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: amd64.S,v 1.1 2003/06/30 08:28:46 xleroy Exp $ */
+
+        .globl  call_gen_code
+        .align  16
+call_gen_code:
+        pushq   %rbx
+        pushq   %rbp
+        pushq   %r12
+        pushq   %r13
+        pushq   %r14
+        pushq   %r15
+	movq	%rdi, %r10
+	movq	%rsi, %rax
+	movq	%rdx, %rbx
+	movq	%rcx, %rdi
+	movq	%r8, %rsi
+        call	*%r10
+        popq    %r15
+        popq    %r14
+        popq    %r13
+        popq    %r12
+        popq    %rbp
+        popq    %rbx
+        ret
+
+        .globl  caml_c_call
+        .align  16
+caml_c_call:
+        jmp     *%rax
+
+	.section	.rodata.cst8,"aM",@progbits,8
+        .globl  caml_negf_mask
+        .align  16
+caml_negf_mask:
+	.quad	0x8000000000000000, 0
+        .globl  caml_absf_mask
+        .align  16
+caml_absf_mask:
+	.quad	0x7FFFFFFFFFFFFFFF, 0
+
+        .comm   young_limit, 8
diff --git a/testasmcomp/arith.cmm b/testasmcomp/arith.cmm
new file mode 100644
index 00000000..442b6582
--- /dev/null
+++ b/testasmcomp/arith.cmm
@@ -0,0 +1,222 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: arith.cmm,v 1.9 2000/06/29 11:45:23 xleroy Exp $ *)
+
+(* Regression test for arithmetic instructions *)
+
+(function "testarith" ()
+   (let r "R"
+   (let d "D"
+   (let x (load int "X")
+   (let y (load int "Y")
+   (let f (load float "F")
+   (let g (load float "G")
+      (addraset r 0 0)
+      (addraset r 1 1)
+      (addraset r 2 -1)
+      (addraset r 3 256)
+      (addraset r 4 65536)
+      (addraset r 5 16777216)
+      (addraset r 6 -256)
+      (addraset r 7 -65536)
+      (addraset r 8 -16777216)
+
+      (addraset r 9 (+ x y))
+      (addraset r 10 (+ x 1))
+      (addraset r 11 (+ x -1))
+
+      (addraset r 12 (+a "R" 8))
+      (addraset r 13 (+a "R" y))
+
+      (addraset r 14 (- x y))
+      (addraset r 15 (- x 1))
+      (addraset r 16 (- x -1))
+
+      (addraset r 17 (-a "R" 8))
+      (addraset r 18 (-a "R" y))
+
+      (addraset r 19 ( * x 2))
+      (addraset r 20 ( * 2 x))
+      (addraset r 21 ( * x 16))
+      (addraset r 22 ( * 16 x))
+      (addraset r 23 ( * x 12345))
+      (addraset r 24 ( * 12345 x))
+      (addraset r 25 ( * x y))
+
+      (addraset r 26 (/ x 2))
+      (addraset r 27 (/ x 16))
+      (addraset r 28 (/ x 7))
+      (addraset r 29 (if (!= y 0) (/ x y) 0))
+
+      (addraset r 30 (mod x 2))
+      (addraset r 31 (mod x 16))
+      (addraset r 32 (if (!= y 0) (mod x y) 0))
+
+      (addraset r 33 (and x y))
+      (addraset r 34 (and x 3))
+      (addraset r 35 (and 3 x))
+
+      (addraset r 36 (or x y))
+      (addraset r 37 (or x 3))
+      (addraset r 38 (or 3 x))
+
+      (addraset r 39 (xor x y))
+      (addraset r 40 (xor x 3))
+      (addraset r 41 (xor 3 x))
+
+      (addraset r 42 (<< x y))
+      (addraset r 43 (<< x 1))
+      (addraset r 44 (<< x 8))
+
+      (addraset r 45 (>>u x y))
+      (addraset r 46 (>>u x 1))
+      (addraset r 47 (>>u x 8))
+
+      (addraset r 48 (>>s x y))
+      (addraset r 49 (>>s x 1))
+      (addraset r 50 (>>s x 8))
+
+      (addraset r 51 (== x y))
+      (addraset r 52 (!= x y))
+      (addraset r 53 (< x y))
+      (addraset r 54 (> x y))
+      (addraset r 55 (<= x y))
+      (addraset r 56 (>= x y))
+      (addraset r 57 (== x 1))
+      (addraset r 58 (!= x 1))
+      (addraset r 59 (< x 1))
+      (addraset r 60 (> x 1))
+      (addraset r 61 (<= x 1))
+      (addraset r 62 (>= x 1))
+
+      (addraset r 63 (==a x y))
+      (addraset r 64 (!=a x y))
+      (addraset r 65 (<a x y))
+      (addraset r 66 (>a x y))
+      (addraset r 67 (<=a x y))
+      (addraset r 68 (>=a x y))
+      (addraset r 69 (==a x 1))
+      (addraset r 70 (!=a x 1))
+      (addraset r 71 (<a x 1))
+      (addraset r 72 (>a x 1))
+      (addraset r 73 (<=a x 1))
+      (addraset r 74 (>=a x 1))
+
+      (addraset r 75 (+ x (<< y 1)))
+      (addraset r 76 (+ x (<< y 2)))
+      (addraset r 77 (+ x (<< y 3)))
+      (addraset r 78 (- x (<< y 1)))
+      (addraset r 79 (- x (<< y 2)))
+      (addraset r 80 (- x (<< y 3)))
+
+      (floataset d 0 0.0)
+      (floataset d 1 1.0)
+      (floataset d 2 -1.0)
+      (floataset d 3 (+f f g))
+      (floataset d 4 (-f f g))
+      (floataset d 5 ( *f f g))
+      (floataset d 6 (/f f g))
+
+      (floataset d 7 (+f f (+f g 1.0)))
+      (floataset d 8 (-f f (+f g 1.0)))
+      (floataset d 9 ( *f f (+f g 1.0)))
+      (floataset d 10 (/f f (+f g 1.0)))
+
+      (floataset d 11 (+f (+f f 1.0) g))
+      (floataset d 12 (-f (+f f 1.0) g))
+      (floataset d 13 ( *f (+f f 1.0) g))
+      (floataset d 14 (/f (+f f 1.0) g))
+
+      (floataset d 15 (+f (+f f 1.0) (+f g 1.0)))
+      (floataset d 16 (-f (+f f 1.0) (+f g 1.0)))
+      (floataset d 17 ( *f (+f f 1.0) (+f g 1.0)))
+      (floataset d 18 (/f (+f f 1.0) (+f g 1.0)))
+
+      (addraset r 81 (==f f g))
+      (addraset r 82 (!=f f g))
+      (addraset r 83 (<f f g))
+      (addraset r 84 (>f f g))
+      (addraset r 85 (<=f f g))
+      (addraset r 86 (>=f f g))
+
+      (floataset d 19 (floatofint x))
+      (addraset r 87 (intoffloat f))
+
+      (if (and (>= x 0) (< x y))
+          (seq (checkbound y x) (addraset r 88 1))
+        (addraset r 88 0))
+
+      (if (< 0 y)
+          (seq (checkbound y 0) (addraset r 89 1))
+        (addraset r 89 0))
+
+      (if (< 5 y)
+          (seq (checkbound y 5) (addraset r 90 1))
+        (addraset r 90 0))
+
+      (addraset r 91 (let res 1 (if (==f f g) [] (assign res 0)) res))
+      (addraset r 92 (let res 1 (if (!=f f g) [] (assign res 0)) res))
+      (addraset r 93 (let res 1 (if (<f f g) [] (assign res 0)) res))
+      (addraset r 94 (let res 1 (if (>f f g) [] (assign res 0)) res))
+      (addraset r 95 (let res 1 (if (<=f f g) [] (assign res 0)) res))
+      (addraset r 96 (let res 1 (if (>=f f g) [] (assign res 0)) res))
+
+      (addraset r 97 (==f (+f f 1.0) (+f g 1.0)))
+      (addraset r 98 (!=f (+f f 1.0) (+f g 1.0)))
+      (addraset r 99 (<f (+f f 1.0) (+f g 1.0)))
+      (addraset r 100 (>f (+f f 1.0) (+f g 1.0)))
+      (addraset r 101 (<=f (+f f 1.0) (+f g 1.0)))
+      (addraset r 102 (>=f (+f f 1.0) (+f g 1.0)))
+
+      (addraset r 103 (==f f (+f g 1.0)))
+      (addraset r 104 (!=f f (+f g 1.0)))
+      (addraset r 105 (<f f (+f g 1.0)))
+      (addraset r 106 (>f f (+f g 1.0)))
+      (addraset r 107 (<=f f (+f g 1.0)))
+      (addraset r 108 (>=f f (+f g 1.0)))
+
+      (addraset r 109 (==f (+f f 1.0) g))
+      (addraset r 110 (!=f (+f f 1.0) g))
+      (addraset r 111 (<f (+f f 1.0) g))
+      (addraset r 112 (>f (+f f 1.0) g))
+      (addraset r 113 (<=f (+f f 1.0) g))
+      (addraset r 114 (>=f (+f f 1.0) g))
+
+      (floataset d 20 (+f (floatofint x) 1.0))
+      (addraset r 115 (intoffloat (+f f 1.0)))
+
+      (floataset d 21 (+f f (load float "G")))
+      (floataset d 22 (+f (load float "G") f))
+      (floataset d 23 (-f f (load float "G")))
+      (floataset d 24 (-f (load float "G") f))
+      (floataset d 25 ( *f f (load float "G")))
+      (floataset d 26 ( *f (load float "G") f))
+      (floataset d 27 (/f f (load float "G")))
+      (floataset d 28 (/f (load float "G") f))
+
+      (floataset d 29 (+f ( *f f 2.0) (load float "G")))
+      (floataset d 30 (+f (load float "G") ( *f f 2.0)))
+      (floataset d 31 (-f ( *f f 2.0) (load float "G")))
+      (floataset d 32 (-f (load float "G") ( *f f 2.0)))
+      (floataset d 33 ( *f ( +f f 2.0) (load float "G")))
+      (floataset d 34 ( *f (load float "G") ( +f f 2.0)))
+      (floataset d 35 (/f ( *f f 2.0) (load float "G")))
+      (floataset d 36 (/f (load float "G") ( *f f 2.0)))
+
+      (floataset d 37 (-f f))
+      (floataset d 38 (absf f))
+
+)))))))
+
+
+
diff --git a/testasmcomp/arm.S b/testasmcomp/arm.S
new file mode 100644
index 00000000..271b0340
--- /dev/null
+++ b/testasmcomp/arm.S
@@ -0,0 +1,45 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: arm.S,v 1.3 2000/01/07 16:44:17 doligez Exp $ */
+
+fp      .req    r11
+ip      .req    r12
+sp      .req    r13
+lr      .req    r14
+pc      .req    r15
+
+        .text
+
+        .global call_gen_code
+        .type   call_gen_code, %function
+        .align  0
+call_gen_code:
+        mov     ip, sp
+        stmfd   sp!, {r4, r5, r6, r7, r8, r9, fp, ip, lr, pc}
+        sub     fp, ip, #4
+    @ r0 is function to call
+    @ r1, r2, r3 are arguments 1, 2, 3
+        mov     r4, r0
+        mov     r0, r1
+        mov     r1, r2
+        mov     r2, r3
+        mov     lr, pc
+        mov     pc, r4
+        ldmea   fp, {r4, r5, r6, r7, r8, r9, fp, sp, pc}
+
+        .global caml_c_call
+        .type   caml_c_call, %function
+        .align  0
+caml_c_call:
+    @ function to call is in r10
+        mov     pc, r10
diff --git a/testasmcomp/checkbound.cmm b/testasmcomp/checkbound.cmm
new file mode 100644
index 00000000..ed823068
--- /dev/null
+++ b/testasmcomp/checkbound.cmm
@@ -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: checkbound.cmm,v 1.3 1999/11/17 18:58:41 xleroy Exp $ *)
+
+(function "checkbound2" (x: int y: int)
+  (checkbound x y))
+
+(function "checkbound1" (x: int)
+  (checkbound x 2))
+
+
diff --git a/testasmcomp/fib.cmm b/testasmcomp/fib.cmm
new file mode 100644
index 00000000..0a7b1da9
--- /dev/null
+++ b/testasmcomp/fib.cmm
@@ -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: fib.cmm,v 1.4 1999/11/17 18:58:41 xleroy Exp $ *)
+
+(function "fib" (n: int)
+  (if (< n 2)
+      1
+    (+ (app "fib" (- n 1) int)
+       (app "fib" (- n 2) int))))
diff --git a/testasmcomp/hppa.S b/testasmcomp/hppa.S
new file mode 100644
index 00000000..6a5ce921
--- /dev/null
+++ b/testasmcomp/hppa.S
@@ -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 Q Public License version 1.0.              *
+;*                                                                   *
+;*********************************************************************
+
+; $Id: hppa.S,v 1.3 1999/11/17 18:58:41 xleroy Exp $
+; 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 STARTPROC .proc ! .callinfo frame=0, no_calls ! .entry
+#define ENDPROC .exit ! .procend
+#endif
+
+#ifdef SYS_nextstep
+#define G(x) _##x
+#define CODESPACE .text
+#define CODE_ALIGN 2
+#define EXPORT_CODE(x) .globl x
+#define STARTPROC
+#define ENDPROC
+#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
+#endif
+
+        CODESPACE
+        .align  CODE_ALIGN
+        EXPORT_CODE(G(call_gen_code))
+G(call_gen_code):
+        STARTPROC
+	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)
+
+; Shuffle the arguments and call
+        copy    %r26, %r22
+        copy    %r25, %r26
+        copy    %r24, %r25
+        copy    %r23, %r24
+        fcpy,dbl %fr5, %fr4
+#ifdef SYS_hpux
+        bl      $$dyncall, %r2
+        nop
+#else
+        ble     0(4, %r22)
+        copy    %r31, %r2
+#endif
+; Shuffle the results
+        copy    %r26, %r28
+; Restore the 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
+
+        ldo	-256(%r30), %r30
+	ldw     -20(%r30), %r2
+        bv      0(%r2)
+        nop
+        ENDPROC
+
+	.align	CODE_ALIGN
+	EXPORT_CODE(caml_c_call)
+G(caml_c_call):
+        STARTPROC
+#ifdef SYS_hpux
+        bl $$dyncall, %r0
+        nop
+#else
+        bv	0(%r22)
+        nop
+#endif
+        ENDPROC
diff --git a/testasmcomp/i386.S b/testasmcomp/i386.S
new file mode 100644
index 00000000..c38c180b
--- /dev/null
+++ b/testasmcomp/i386.S
@@ -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: i386.S,v 1.5 1999/11/17 18:58:41 xleroy Exp $ */
+
+/* Linux with ELF binaries does not prefix identifiers with _.
+   Linux with a.out binaries, FreeBSD, and NextStep do. */
+
+#ifdef SYS_linux_elf
+#define G(x) x
+#define FUNCTION_ALIGN 16
+#else
+#define G(x) _##x
+#define FUNCTION_ALIGN 4
+#endif
+
+        .globl  G(call_gen_code)
+        .align  FUNCTION_ALIGN
+G(call_gen_code):
+        pushl %ebp
+        movl %esp,%ebp
+        pushl %ebx
+        pushl %esi
+        pushl %edi
+        movl 12(%ebp),%eax
+        movl 16(%ebp),%ebx
+        movl 20(%ebp),%ecx
+        movl 24(%ebp),%edx
+        call *8(%ebp)
+        popl %edi
+        popl %esi
+        popl %ebx
+        popl %ebp
+        ret
+
+        .globl  G(caml_c_call)
+        .align  FUNCTION_ALIGN
+G(caml_c_call):
+        ffree   %st(0)
+        ffree   %st(1)
+        ffree   %st(2)
+        ffree   %st(3)
+        jmp     *%eax
+
+        .comm   G(caml_exception_pointer), 4
+        .comm   G(young_ptr), 4
+        .comm   G(young_start), 4
diff --git a/testasmcomp/i386nt.asm b/testasmcomp/i386nt.asm
new file mode 100644
index 00000000..72eb3745
--- /dev/null
+++ b/testasmcomp/i386nt.asm
@@ -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: i386nt.asm,v 1.3 1999/11/17 18:58:42 xleroy Exp $
+
+	.386
+	.MODEL FLAT
+
+        .CODE
+        PUBLIC  _call_gen_code
+        ALIGN   4
+_call_gen_code:
+        push	ebp
+        mov	ebp, esp
+        push	ebx
+        push	esi
+        push	edi
+        mov	eax, [ebp+12]
+        mov	ebx, [ebp+16]
+        mov	ecx, [ebp+20]
+        mov	edx, [ebp+24]
+        call	DWORD PTR [ebp+8]
+        pop	edi
+        pop	esi
+        pop	ebx
+        pop	ebp
+        ret	
+
+        PUBLIC  _caml_c_call
+        ALIGN   4
+_caml_c_call:
+        ffree	st(0)
+        ffree	st(1)
+        ffree	st(2)
+        ffree	st(3)
+        jmp	eax
+
+        PUBLIC  _caml_call_gc
+        PUBLIC  _caml_alloc
+        PUBLIC  _caml_alloc1
+        PUBLIC  _caml_alloc2
+        PUBLIC  _caml_alloc3       
+_caml_call_gc:
+_caml_alloc:
+_caml_alloc1:
+_caml_alloc2:
+_caml_alloc3:
+        int     3      
+
+        .DATA
+        PUBLIC	_caml_exception_pointer
+_caml_exception_pointer	dword 0
+        PUBLIC	_young_ptr
+_young_ptr	dword 0
+        PUBLIC	_young_limit
+_young_limit	dword 0
+
+        END
diff --git a/testasmcomp/ia64.S b/testasmcomp/ia64.S
new file mode 100644
index 00000000..a3e89fcb
--- /dev/null
+++ b/testasmcomp/ia64.S
@@ -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: ia64.S,v 1.5 2001/07/12 12:54:24 doligez Exp $ */
+
+#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
+
+        .text
+        .align 16
+
+        .global call_gen_code#
+        .proc   call_gen_code#
+
+call_gen_code:
+        /* Allocate 64 "out" registers (for the Caml code) and no locals */
+        alloc   r3 = ar.pfs, 0, 0, 64, 0
+
+        /* Save PFS, return address and GP on stack */
+        add     sp = -368, sp ;;
+        add     r2 = 16, sp ;;
+        ST8OFF(r2,r3,8) ;;
+        mov     r3 = b0 ;;
+        ST8OFF(r2,r3,8) ;;
+        ST8OFF(r2,gp,8) ;;
+
+        /* Save predicates on stack */
+        mov     r3 = pr ;;
+        st8     [r2] = r3
+
+        /* Save callee-save floating-point registers on stack */
+        add     r2 = 48, sp
+        add     r3 = 64, sp ;;
+        STFSPILLOFF(r2,f2,16) ;;
+        STFSPILLOFF(r3,f3,16) ;;
+        STFSPILLOFF(r2,f4,16) ;;
+        STFSPILLOFF(r3,f5,16) ;;
+        STFSPILLOFF(r2,f16,16) ;;
+        STFSPILLOFF(r3,f17,16) ;;
+        STFSPILLOFF(r2,f18,16) ;;
+        STFSPILLOFF(r3,f19,16) ;;
+        STFSPILLOFF(r2,f20,16) ;;
+        STFSPILLOFF(r3,f21,16) ;;
+        STFSPILLOFF(r2,f22,16) ;;
+        STFSPILLOFF(r3,f23,16) ;;
+        STFSPILLOFF(r2,f24,16) ;;
+        STFSPILLOFF(r3,f25,16) ;;
+        STFSPILLOFF(r2,f26,16) ;;
+        STFSPILLOFF(r3,f27,16) ;;
+        STFSPILLOFF(r2,f28,16) ;;
+        STFSPILLOFF(r3,f29,16) ;;
+        STFSPILLOFF(r2,f30,16) ;;
+        STFSPILLOFF(r3,f31,16) ;;
+
+        /* Recover entry point and gp from the function pointer in in0 */
+        LD8OFF(r2,r32,8) ;;
+        ld8     r3 = [r32] ;;
+        mov     b6 = r2
+        mov     gp = r3 ;;
+
+        /* Shift arguments r33 ... r35 to r32 ... r34 */
+        mov     r32 = r33
+        mov     r33 = r34
+        mov     r34 = r35
+
+        /* Do the call */
+        br.call.sptk b0 = b6 ;;
+
+        /* Restore the saved floating-point registers */
+        add     r2 = 48, sp
+        add     r3 = 64, sp ;;
+        LDFFILLOFF(f2,r2,16) ;;
+        LDFFILLOFF(f3,r3,16) ;;
+        LDFFILLOFF(f4,r2,16) ;;
+        LDFFILLOFF(f5,r3,16) ;;
+        LDFFILLOFF(f16,r2,16) ;;
+        LDFFILLOFF(f17,r3,16) ;;
+        LDFFILLOFF(f18,r2,16) ;;
+        LDFFILLOFF(f19,r3,16) ;;
+        LDFFILLOFF(f20,r2,16) ;;
+        LDFFILLOFF(f21,r3,16) ;;
+        LDFFILLOFF(f22,r2,16) ;;
+        LDFFILLOFF(f23,r3,16) ;;
+        LDFFILLOFF(f24,r2,16) ;;
+        LDFFILLOFF(f25,r3,16) ;;
+        LDFFILLOFF(f26,r2,16) ;;
+        LDFFILLOFF(f27,r3,16) ;;
+        LDFFILLOFF(f28,r2,16) ;;
+        LDFFILLOFF(f29,r3,16) ;;
+        LDFFILLOFF(f30,r2,16) ;;
+        LDFFILLOFF(f31,r3,16) ;;
+
+        /* Restore gp, predicates and return */
+        add     r2 = 16, sp ;;
+        LD8OFF(r3,r2,8) ;;
+        mov     ar.pfs = r3
+        LD8OFF(r3,r2,8) ;;
+        mov     b0 = r3
+        LD8OFF(gp,r2,8) ;;
+        LD8OFF(r3,r2,8) ;;
+        mov     pr = r3, -1
+
+        br.ret.sptk.many b0 ;;
+
+        .endp   call_gen_code#
diff --git a/testasmcomp/integr.cmm b/testasmcomp/integr.cmm
new file mode 100644
index 00000000..3f55b60b
--- /dev/null
+++ b/testasmcomp/integr.cmm
@@ -0,0 +1,30 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: integr.cmm,v 1.5 2000/06/29 11:45:23 xleroy Exp $ *)
+
+(function "square" (x: float)
+   ( *f x x))
+
+(function "integr" (f: addr low: float high: float n: int)
+  (let (h (/f (-f high low) (floatofint n))
+        x low
+        s 0.0
+        i n)
+    (while (> i 0)
+      (assign s (+f s (app f x float)))
+      (assign x (+f x h))
+      (assign i (- i 1)))
+    ( *f s h)))
+
+(function "test" (n: int)
+  (app "integr" "square" 0.0 1.0 n float))
diff --git a/testasmcomp/lexcmm.mli b/testasmcomp/lexcmm.mli
new file mode 100644
index 00000000..f81000e4
--- /dev/null
+++ b/testasmcomp/lexcmm.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: lexcmm.mli,v 1.4 1999/11/17 18:58:42 xleroy Exp $ *)
+
+val token: Lexing.lexbuf -> Parsecmm.token
+
+type error =
+    Illegal_character
+  | Unterminated_comment
+  | Unterminated_string
+
+exception Error of error
+
+val report_error: Lexing.lexbuf -> error -> unit
diff --git a/testasmcomp/lexcmm.mll b/testasmcomp/lexcmm.mll
new file mode 100644
index 00000000..b498d7ff
--- /dev/null
+++ b/testasmcomp/lexcmm.mll
@@ -0,0 +1,228 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: lexcmm.mll,v 1.8 2000/06/25 19:54:50 xleroy Exp $ *)
+
+{
+open Parsecmm
+
+type error =
+    Illegal_character
+  | Unterminated_comment
+  | Unterminated_string
+
+exception Error of error
+
+(* For nested comments *)
+
+let comment_depth = ref 0
+
+(* The table of keywords *)
+
+let keyword_table =
+  Misc.create_hashtable 149 [
+    "absf", ABSF;
+    "addr", ADDR;
+    "align", ALIGN;
+    "alloc", ALLOC;
+    "and", AND;
+    "app", APPLY;
+    "assign", ASSIGN;
+    "byte", BYTE;
+    "case", CASE;
+    "catch", CATCH;
+    "checkbound", CHECKBOUND;
+    "exit", EXIT;
+    "extcall", EXTCALL;
+    "float", FLOAT;
+    "float32", FLOAT32;
+    "float64", FLOAT64;
+    "floatofint", FLOATOFINT;
+    "function", FUNCTION;
+    "half", HALF;
+    "if", IF;
+    "int", INT;
+    "int32", INT32;
+    "intoffloat", INTOFFLOAT;
+    "string", KSTRING;
+    "let", LET;
+    "load", LOAD;
+    "mod", MODI;
+    "or", OR;
+    "proj", PROJ;
+    "raise", RAISE;
+    "seq", SEQ;
+    "signed", SIGNED;
+    "skip", SKIP;
+    "store", STORE;
+    "switch", SWITCH;
+    "try", TRY;
+    "unit", UNIT;
+    "unsigned", UNSIGNED;
+    "while", WHILE;
+    "with", WITH;
+    "xor", XOR;
+    "addraref", ADDRAREF;
+    "intaref", INTAREF;
+    "floataref", FLOATAREF;
+    "addraset", ADDRASET;
+    "intaset", INTASET;
+    "floataset", FLOATASET
+]
+
+(* To buffer string literals *)
+
+let initial_string_buffer = String.create 256
+let string_buff = ref initial_string_buffer
+let string_index = ref 0
+
+let reset_string_buffer () =
+  string_buff := initial_string_buffer;
+  string_index := 0
+
+let store_string_char c =
+  if !string_index >= String.length (!string_buff) then begin
+    let new_buff = String.create (String.length (!string_buff) * 2) in
+      String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff));
+      string_buff := new_buff
+  end;
+  String.unsafe_set (!string_buff) (!string_index) c;
+  incr string_index
+
+let get_stored_string () =
+  let s = String.sub (!string_buff) 0 (!string_index) in
+  string_buff := initial_string_buffer;
+  s
+
+(* To translate escape sequences *)
+
+let char_for_backslash = function
+    'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
+
+let char_for_decimal_code lexbuf i =
+  Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
+               10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
+                    (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48))
+
+(* Error report *)
+
+let report_error lexbuf msg =
+  prerr_string "Lexical error around character ";
+  prerr_int (Lexing.lexeme_start lexbuf);
+  match msg with
+    Illegal_character ->
+      prerr_string ": illegal character"
+  | Unterminated_comment ->
+      prerr_string ": unterminated comment"
+  | Unterminated_string ->
+      prerr_string ": unterminated string"
+
+}
+
+rule token = parse
+    [' ' '\010' '\013' '\009' '\012'] +
+      { token lexbuf }
+  | "+a" { ADDA }
+  | "+f" { ADDF }
+  | "+" { ADDI }
+  | ">>s" { ASR }
+  | ":" { COLON }
+  | "/f" { DIVF }
+  | "/" { DIVI }
+  | eof { EOF }
+  | "==a" { EQA }
+  | "==f" { EQF }
+  | "==" { EQI }
+  | ">=a" { GEA }
+  | ">=f" { GEF }
+  | ">=" { GEI }
+  | ">a" { GTA }
+  | ">f" { GTF }
+  | ">" { GTI }
+  | "[" { LBRACKET }
+  | "<=a" { LEA }
+  | "<=f" { LEF }
+  | "<=" { LEI }
+  | "(" { LPAREN }
+  | "<<" { LSL }
+  | ">>u" { LSR }
+  | "<a" { LTA }
+  | "<f" { LTF }
+  | "<" { LTI }
+  | "*f" { MULF }
+  | "*" { MULI }
+  | "!=a" { NEA }
+  | "!=f" { NEF }
+  | "!=" { NEI }
+  | "]" { RBRACKET }
+  | ")" { RPAREN }
+  | "*" { STAR }
+  | "-a" { SUBA }
+  | "-f" { SUBF }
+  | "-" { SUBI }
+  | '-'? (['0'-'9']+ | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+
+                     | "0o" ['0'-'7']+ | "0b" ['0'-'1']+)
+      { INTCONST(int_of_string(Lexing.lexeme lexbuf)) }
+  | '-'? ['0'-'9']+ 'a'
+      { let s = Lexing.lexeme lexbuf in
+        POINTER(int_of_string(String.sub s 0 (String.length s - 1))) }
+  | '-'? ['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
+      { FLOATCONST(Lexing.lexeme lexbuf) }
+  | ['A'-'Z' 'a'-'z' '\223'-'\246' '\248'-'\255' ]
+    (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'
+      '\'' '0'-'9' ]) *
+      { let s = Lexing.lexeme lexbuf in
+        try
+          Hashtbl.find keyword_table s
+        with Not_found ->
+          IDENT s }
+  | "\""
+      { reset_string_buffer();
+        string lexbuf;
+        STRING (get_stored_string()) }
+  | "(*"
+      { comment_depth := 1;
+        comment lexbuf;
+        token lexbuf }
+  | _ { raise(Error(Illegal_character)) }
+
+and comment = parse
+    "(*"
+      { comment_depth := succ !comment_depth; comment lexbuf }
+  | "*)"
+      { comment_depth := pred !comment_depth;
+        if !comment_depth > 0 then comment lexbuf }
+  | eof
+      { raise (Error(Unterminated_comment)) }
+  | _
+      { comment lexbuf }
+
+and string = parse
+    '"'
+      { () }
+  | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] +
+      { string lexbuf }
+  | '\\' ['\\' '"' 'n' 't' 'b' 'r']
+      { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
+        string lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+      { store_string_char(char_for_decimal_code lexbuf 1);
+         string lexbuf }
+  | eof
+      { raise (Error(Unterminated_string)) }
+  | _
+      { store_string_char(Lexing.lexeme_char lexbuf 0);
+        string lexbuf }
diff --git a/testasmcomp/m68k.S b/testasmcomp/m68k.S
new file mode 100644
index 00000000..86bed12c
--- /dev/null
+++ b/testasmcomp/m68k.S
@@ -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: m68k.S,v 1.2 1999/11/17 18:58:42 xleroy Exp $
+
+| call_gen_code is used with the following types:
+|       unit -> int
+|       int -> int
+|       int -> double
+|       int * int * address -> void
+|       int * int -> void
+|       unit -> unit
+| Hence arg1 -> d0, arg2 -> d1, arg3 -> a0, 
+| and we need a special case for int -> double
+
+        .text
+        .globl  _call_gen_code
+_call_gen_code:
+        link    a6, #0
+        movem   d2-d7/a2-a6, a7@-
+        fmovem  fp2-fp7, a7@-
+        movel   a6@(8), a1
+        movel   a6@(12), d0
+        movel   a6@(16), d1
+        movel   a6@(20), a0
+        jsr     a1@
+        fmovem  a7@+, fp2-fp7
+        movem   a7@+, d2-d7/a2-a6
+        unlk    a6
+        rts
+
+        .globl  _call_gen_code_float
+_call_gen_code_float:
+        link    a6, #0
+        moveml  d2-d7/a2-a6, a7@-
+        fmovem  fp2-fp7, a7@-
+        movel   a6@(8), a1
+        movel   a6@(12), d0
+        jsr     a1@
+        fmoved  fp0, a7@-
+        movel   a7@+, d0
+        movel   a7@+, d1
+        fmovem  a7@+, fp2-fp7
+        moveml  a7@+, d2-d7/a2-a6
+        unlk    a6
+        rts
+
+        .globl  _caml_c_call
+_caml_c_call:
+        jmp     a0@
diff --git a/testasmcomp/main.c b/testasmcomp/main.c
new file mode 100644
index 00000000..02f6e183
--- /dev/null
+++ b/testasmcomp/main.c
@@ -0,0 +1,126 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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.c,v 1.12 2003/06/30 08:28:46 xleroy Exp $ */
+
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+void caml_array_bound_error(void)
+{
+  fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
+  exit(2);
+}
+
+void print_string(char * s)
+{
+  fputs(s, stdout);
+}
+
+void printf_int(char * fmt, int arg)
+{
+  printf(fmt, arg);
+}
+
+#ifdef SORT
+
+int cmpint(const void * i, const void * j)
+{
+  long vi = *((long *) i);
+  long vj = *((long *) j);
+  if (vi == vj) return 0;
+  if (vi < vj) return -1;
+  return 1;
+}
+
+#endif
+
+int main(int argc, char **argv)
+{
+#ifdef UNIT_INT
+  { extern int FUN();
+    extern int call_gen_code();
+    printf("%d\n", call_gen_code(FUN));
+  }
+#else
+  if (argc < 2) {
+    fprintf(stderr, "Usage: %s [int arg]\n", argv[0]);
+    exit(2);
+  }
+#ifdef INT_INT
+  { extern int FUN();
+    extern int call_gen_code();
+    printf("%d\n", call_gen_code(FUN, atoi(argv[1])));
+  }
+#endif
+#ifdef INT_FLOAT
+  { extern double FUN();
+#ifdef __mc68020__
+#define call_gen_code call_gen_code_float
+#endif
+    extern double call_gen_code();
+    printf("%f\n", call_gen_code(FUN, atoi(argv[1])));
+  }
+#endif
+#ifdef SORT
+  { extern void FUN();
+    extern void call_gen_code();
+    long n;
+    long * a, * b;
+    long i;
+
+    srand(argc >= 3 ? atoi(argv[2]) : time((char *) 0));
+    n = atoi(argv[1]);
+    a = (long *) malloc(n * sizeof(long));
+    for (i = 0 ; i < n; i++) a[i] = rand() & 0xFFF;
+#ifdef DEBUG
+    for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n");
+#endif
+    b = (long *) malloc(n * sizeof(long));
+    for (i = 0; i < n; i++) b[i] = a[i];
+    call_gen_code(FUN, 0, n-1, a);
+#ifdef DEBUG
+    for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n");
+#endif
+    qsort(b, n, sizeof(long), cmpint);
+    for (i = 0; i < n; i++) {
+      if (a[i] != b[i]) { printf("Bug!\n"); return 2; }
+    }
+    printf("OK\n");
+  }
+#endif
+#endif
+#ifdef CHECKBOUND
+  { extern void checkbound1(), checkbound2();
+    extern void call_gen_code();
+    long x, y;
+    x = atoi(argv[1]);
+    if (argc >= 3) {
+      y = atoi(argv[2]);
+      if ((unsigned long) x < (unsigned long) y)
+        printf("Should not trap\n");
+      else
+        printf("Should trap\n");
+      call_gen_code(checkbound2, y, x);
+    } else {
+      if (2 < (unsigned long) x)
+        printf("Should not trap\n");
+      else
+        printf("Should trap\n");
+      call_gen_code(checkbound1, x);
+    }
+    printf("OK\n");
+  }
+#endif
+  return 0;
+}
diff --git a/testasmcomp/main.ml b/testasmcomp/main.ml
new file mode 100644
index 00000000..4866a1a3
--- /dev/null
+++ b/testasmcomp/main.ml
@@ -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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: main.ml,v 1.12 2000/07/07 14:09:23 xleroy Exp $ *)
+
+open Clflags
+
+let compile_file filename =
+  Compilenv.reset "test";
+  Emit.begin_assembly();
+  let ic = open_in filename in
+  let lb = Lexing.from_channel ic in
+  try
+    while true do
+      Asmgen.compile_phrase Format.std_formatter (Parsecmm.phrase Lexcmm.token lb)
+    done
+  with
+      End_of_file ->
+        close_in ic; Emit.end_assembly()
+    | 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
+
+let usage = "Usage: codegen <options> <files>\noptions are:"
+
+let main() =
+  Arg.parse [
+     "-dcmm", Arg.Set dump_cmm, "";
+     "-dsel", Arg.Set dump_selection, "";
+     "-dlive", Arg.Unit(fun () -> dump_live := true;
+                                  Printmach.print_live := true), "";
+     "-dspill", Arg.Set dump_spill, "";
+     "-dsplit", Arg.Set dump_split, "";
+     "-dinterf", Arg.Set dump_interf, "";
+     "-dprefer", Arg.Set dump_prefer, "";
+     "-dalloc", Arg.Set dump_regalloc, "";
+     "-dreload", Arg.Set dump_reload, "";
+     "-dscheduling", Arg.Set dump_scheduling, "";
+     "-dlinear", Arg.Set dump_linear, ""
+    ] compile_file usage
+
+let _ = (*Printexc.catch*) main (); exit 0
+
diff --git a/testasmcomp/mainarith.c b/testasmcomp/mainarith.c
new file mode 100644
index 00000000..9594c25c
--- /dev/null
+++ b/testasmcomp/mainarith.c
@@ -0,0 +1,304 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: mainarith.c,v 1.20 2000/07/21 08:09:05 xleroy Exp $ */
+
+#include <stdio.h>
+#include <math.h>
+
+void caml_array_bound_error(void)
+{
+  fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
+  exit(2);
+}
+
+long R[200];
+double D[40];
+long X, Y;
+double F, G;
+
+#define INTTEST(arg,res) \
+  { long result = (res); \
+    if (arg != result) \
+      printf("Failed test \"%s == %s\" for X=%ld and Y=%ld: result %ld, expected %ld\n", \
+             #arg, #res, X, Y, arg, result); \
+  }
+#define INTFLOATTEST(arg,res) \
+  { long result = (res); \
+    if (arg != result) \
+      printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %ld, expected %ld\n", \
+             #arg, #res, F, G, arg, result); \
+  }
+#define FLOATTEST(arg,res) \
+  { double result = (res); \
+    if (arg < result || arg > result) \
+      printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %.15g, expected %.15g\n", \
+             #arg, #res, F, G, arg, result); \
+  }
+#define FLOATINTTEST(arg,res) \
+  { double result = (res); \
+    if (arg < result || arg > result) \
+      printf("Failed test \"%s == %s\" for X=%ld and Y=%ld: result %.15g, expected %.15g\n", \
+             #arg, #res, X, Y, arg, result); \
+  }
+
+extern void call_gen_code();
+extern void testarith();
+
+void do_test(void)
+{
+      call_gen_code(testarith);
+
+      INTTEST(R[0], 0);
+      INTTEST(R[1], 1);
+      INTTEST(R[2], -1);
+      INTTEST(R[3], 256);
+      INTTEST(R[4], 65536);
+      INTTEST(R[5], 16777216);
+      INTTEST(R[6], -256);
+      INTTEST(R[7], -65536);
+      INTTEST(R[8], -16777216);
+
+      INTTEST(R[9], (X + Y));
+      INTTEST(R[10], (X + 1));
+      INTTEST(R[11], (X + -1));
+
+      INTTEST(R[12], ((long) ((char *)R + 8)));
+      INTTEST(R[13], ((long) ((char *)R + Y)));
+
+      INTTEST(R[14], (X - Y));
+      INTTEST(R[15], (X - 1));
+      INTTEST(R[16], (X - -1));
+
+      INTTEST(R[17], ((long) ((char *)R - 8)));
+      INTTEST(R[18], ((long) ((char *)R - Y)));
+
+      INTTEST(R[19], (X * 2));
+      INTTEST(R[20], (2 * X));
+      INTTEST(R[21], (X * 16));
+      INTTEST(R[22], (16 * X));
+      INTTEST(R[23], (X * 12345));
+      INTTEST(R[24], (12345 * X));
+      INTTEST(R[25], (X * Y));
+
+      INTTEST(R[26], (X / 2));
+      INTTEST(R[27], (X / 16));
+      INTTEST(R[28], (X / 7));
+      INTTEST(R[29], (Y != 0 ? X / Y : 0));
+
+      INTTEST(R[30], (X % 2));
+      INTTEST(R[31], (X % 16));
+      INTTEST(R[32], (Y != 0 ? X % Y : 0));
+
+      INTTEST(R[33], (X & Y));
+      INTTEST(R[34], (X & 3));
+      INTTEST(R[35], (3 & X));
+
+      INTTEST(R[36], (X | Y));
+      INTTEST(R[37], (X | 3));
+      INTTEST(R[38], (3 | X));
+
+      INTTEST(R[39], (X ^ Y));
+      INTTEST(R[40], (X ^ 3));
+      INTTEST(R[41], (3 ^ X));
+
+      INTTEST(R[42], (X << Y));
+      INTTEST(R[43], (X << 1));
+      INTTEST(R[44], (X << 8));
+
+      INTTEST(R[45], ((unsigned long) X >> Y));
+      INTTEST(R[46], ((unsigned long) X >> 1));
+      INTTEST(R[47], ((unsigned long) X >> 8));
+
+      INTTEST(R[48], (X >> Y));
+      INTTEST(R[49], (X >> 1));
+      INTTEST(R[50], (X >> 8));
+
+      INTTEST(R[51], (X == Y));
+      INTTEST(R[52], (X != Y));
+      INTTEST(R[53], (X < Y));
+      INTTEST(R[54], (X > Y));
+      INTTEST(R[55], (X <= Y));
+      INTTEST(R[56], (X >= Y));
+      INTTEST(R[57], (X == 1));
+      INTTEST(R[58], (X != 1));
+      INTTEST(R[59], (X < 1));
+      INTTEST(R[60], (X > 1));
+      INTTEST(R[61], (X <= 1));
+      INTTEST(R[62], (X >= 1));
+
+      INTTEST(R[63], ((char *)X == (char *)Y));
+      INTTEST(R[64], ((char *)X != (char *)Y));
+      INTTEST(R[65], ((char *)X < (char *)Y));
+      INTTEST(R[66], ((char *)X > (char *)Y));
+      INTTEST(R[67], ((char *)X <= (char *)Y));
+      INTTEST(R[68], ((char *)X >= (char *)Y));
+      INTTEST(R[69], ((char *)X == (char *)1));
+      INTTEST(R[70], ((char *)X != (char *)1));
+      INTTEST(R[71], ((char *)X < (char *)1));
+      INTTEST(R[72], ((char *)X > (char *)1));
+      INTTEST(R[73], ((char *)X <= (char *)1));
+      INTTEST(R[74], ((char *)X >= (char *)1));
+
+      INTTEST(R[75], (X + (Y << 1)));
+      INTTEST(R[76], (X + (Y << 2)));
+      INTTEST(R[77], (X + (Y << 3)));
+      INTTEST(R[78], (X - (Y << 1)));
+      INTTEST(R[79], (X - (Y << 2)));
+      INTTEST(R[80], (X - (Y << 3)));
+
+      FLOATTEST(D[0], 0.0);
+      FLOATTEST(D[1], 1.0);
+      FLOATTEST(D[2], -1.0);
+      FLOATTEST(D[3], (F + G));
+      FLOATTEST(D[4], (F - G));
+      FLOATTEST(D[5], (F * G));
+      FLOATTEST(D[6], F / G);
+
+      FLOATTEST(D[7], (F + (G + 1.0)));
+      FLOATTEST(D[8], (F - (G + 1.0)));
+      FLOATTEST(D[9], (F * (G + 1.0)));
+      FLOATTEST(D[10], F / (G + 1.0));
+
+      FLOATTEST(D[11], ((F + 1.0) + G));
+      FLOATTEST(D[12], ((F + 1.0) - G));
+      FLOATTEST(D[13], ((F + 1.0) * G));
+      FLOATTEST(D[14], (F + 1.0) / G);
+
+      FLOATTEST(D[15], ((F + 1.0) + (G + 1.0)));
+      FLOATTEST(D[16], ((F + 1.0) - (G + 1.0)));
+      FLOATTEST(D[17], ((F + 1.0) * (G + 1.0)));
+      FLOATTEST(D[18], (F + 1.0) / (G + 1.0));
+
+      INTFLOATTEST(R[81], (F == G));
+      INTFLOATTEST(R[82], (F != G));
+      INTFLOATTEST(R[83], (F < G));
+      INTFLOATTEST(R[84], (F > G));
+      INTFLOATTEST(R[85], (F <= G));
+      INTFLOATTEST(R[86], (F >= G));
+
+      FLOATINTTEST(D[19], (double) X);
+      INTFLOATTEST(R[87], (long) F);
+
+      INTTEST(R[88], (X >= 0) && (X < Y));
+      INTTEST(R[89], (0 < Y));
+      INTTEST(R[90], (5 < Y));
+
+      INTFLOATTEST(R[91], (F == G));
+      INTFLOATTEST(R[92], (F != G));
+      INTFLOATTEST(R[93], (F < G));
+      INTFLOATTEST(R[94], (F > G));
+      INTFLOATTEST(R[95], (F <= G));
+      INTFLOATTEST(R[96], (F >= G));
+
+      INTFLOATTEST(R[97], (F + 1.0 == G + 1.0));
+      INTFLOATTEST(R[98], (F + 1.0 != G + 1.0));
+      INTFLOATTEST(R[99], (F + 1.0 < G + 1.0));
+      INTFLOATTEST(R[100], (F + 1.0 > G + 1.0));
+      INTFLOATTEST(R[101], (F + 1.0 <= G + 1.0));
+      INTFLOATTEST(R[102], (F + 1.0 >= G + 1.0));
+
+      INTFLOATTEST(R[103], (F == G + 1.0));
+      INTFLOATTEST(R[104], (F != G + 1.0));
+      INTFLOATTEST(R[105], (F < G + 1.0));
+      INTFLOATTEST(R[106], (F > G + 1.0));
+      INTFLOATTEST(R[107], (F <= G + 1.0));
+      INTFLOATTEST(R[108], (F >= G + 1.0));
+
+      INTFLOATTEST(R[109], (F + 1.0 == G));
+      INTFLOATTEST(R[110], (F + 1.0 != G));
+      INTFLOATTEST(R[111], (F + 1.0 < G));
+      INTFLOATTEST(R[112], (F + 1.0 > G));
+      INTFLOATTEST(R[113], (F + 1.0 <= G));
+      INTFLOATTEST(R[114], (F + 1.0 >= G));
+
+      FLOATINTTEST(D[20], ((double) X) + 1.0);
+      INTFLOATTEST(R[115], (long)(F + 1.0));
+
+      FLOATTEST(D[21], F + G);
+      FLOATTEST(D[22], G + F);
+      FLOATTEST(D[23], F - G);
+      FLOATTEST(D[24], G - F);
+      FLOATTEST(D[25], F * G);
+      FLOATTEST(D[26], G * F);
+      FLOATTEST(D[27], F / G);
+      FLOATTEST(D[28], G / F);
+
+      FLOATTEST(D[29], (F * 2.0) + G);
+      FLOATTEST(D[30], G + (F * 2.0));
+      FLOATTEST(D[31], (F * 2.0) - G);
+      FLOATTEST(D[32], G - (F * 2.0));
+      FLOATTEST(D[33], (F + 2.0) * G);
+      FLOATTEST(D[34], G * (F + 2.0));
+      FLOATTEST(D[35], (F * 2.0) / G);
+      FLOATTEST(D[36], G / (F * 2.0));
+
+      FLOATTEST(D[37], - F);
+      FLOATTEST(D[38], fabs(F));
+}
+
+#ifdef __i386__
+#ifdef __FreeBSD__
+#include <floatingpoint.h>
+#endif
+#endif
+
+void init_ieee_floats(void)
+{
+#ifdef __i386__
+#ifdef __FreeBSD__
+  fpsetmask(0);
+#endif
+#endif
+}
+
+int main(int argc, char **argv)
+{
+  double weird[4];
+
+  init_ieee_floats();
+
+  if (argc >= 5) {
+    X = atoi(argv[1]);
+    Y = atoi(argv[2]);
+    sscanf(argv[3], "%lf", &F);
+    sscanf(argv[4], "%lf", &G);
+    do_test();
+    return 0;
+  }
+  for(Y = -2; Y <= 2; Y++) {
+    for (X = -2; X <= 2; X++) {
+      F = X; G = Y; do_test();
+    }
+  }
+  if (!(argc >= 2 && strcmp(argv[1], "noinf"))) {
+    weird[0] = 0.0;
+    weird[1] = 1.0 / weird[0];         /* +infty */
+    weird[2] = -1.0 / weird[0];        /* -infty */
+    weird[3] = 0.0 / weird[0];         /* NaN */
+    for (X = 0; X < 4; X++) {
+      for (Y = 0; Y < 4; Y++) {
+        F = weird[X]; G = weird[Y]; do_test();
+      }
+    }
+  }
+  while(1) {
+    X = (rand() & 0x1FFFFFFF) - 0x10000000;
+    Y = (rand() & 0x1FFFFFFF) - 0x10000000;
+    F = X / 1e3;
+    G = Y / 1e3;
+    do_test();
+    printf("."); fflush(stdout);
+  }
+  return 0;
+}
+
diff --git a/testasmcomp/mips.s b/testasmcomp/mips.s
new file mode 100644
index 00000000..f5bc84d3
--- /dev/null
+++ b/testasmcomp/mips.s
@@ -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: mips.s,v 1.3 1999/11/29 19:04:19 doligez Exp $ */
+
+        .globl  call_gen_code
+        .ent    call_gen_code
+call_gen_code:
+        subu    $sp, $sp, 0x90
+        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)
+    /* Shuffle arguments */
+        move    $8, $5
+        move    $9, $6
+        move    $10, $7
+        move    $25, $4
+        jal     $4
+    /* Restore registers */
+        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)
+        addu    $sp, $sp, 0x90
+        j       $31
+
+        .end    call_gen_code
+
+/* Call a C function */
+
+        .globl  caml_c_call
+        .ent    caml_c_call
+caml_c_call:
+        move    $25, $24
+        j       $24
+        .end    caml_c_call
diff --git a/testasmcomp/parsecmm.mly b/testasmcomp/parsecmm.mly
new file mode 100644
index 00000000..99ef8dfc
--- /dev/null
+++ b/testasmcomp/parsecmm.mly
@@ -0,0 +1,325 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           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: parsecmm.mly,v 1.11 2003/06/30 08:28:48 xleroy Exp $ */
+
+/* A simple parser for C-- */
+
+%{
+open Cmm
+open Parsecmmaux
+
+let rec make_letdef def body =
+  match def with
+    [] -> body
+  | (id, def) :: rem ->
+      unbind_ident id;
+      Clet(id, def, make_letdef rem body)
+
+let make_switch n selector caselist =
+  let index = Array.create n 0 in
+  let casev = Array.of_list caselist in
+  let actv = Array.create (Array.length casev) (Cexit(0,[])) in
+  for i = 0 to Array.length casev - 1 do
+    let (posl, e) = casev.(i) in
+    List.iter (fun pos -> index.(pos) <- i) posl;
+    actv.(i) <- e
+  done;
+  Cswitch(selector, index, actv)
+
+let access_array base numelt size =
+  match numelt with
+    Cconst_int 0 -> base
+  | Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)])
+  | _ -> Cop(Cadda, [base;
+                     Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)])])
+
+%}
+
+%token ABSF
+%token ADDA
+%token ADDF
+%token ADDI
+%token ADDR
+%token ALIGN
+%token ALLOC
+%token AND
+%token APPLY
+%token ASR
+%token ASSIGN
+%token BYTE
+%token CASE
+%token CATCH
+%token CHECKBOUND
+%token COLON
+%token DIVF
+%token DIVI
+%token EOF
+%token EQA
+%token EQF
+%token EQI
+%token EXIT
+%token EXTCALL
+%token FLOAT
+%token FLOAT32
+%token FLOAT64
+%token <string> FLOATCONST
+%token FLOATOFINT
+%token FUNCTION
+%token GEA
+%token GEF
+%token GEI
+%token GTA
+%token GTF
+%token GTI
+%token HALF
+%token <string> IDENT
+%token IF
+%token INT
+%token INT32
+%token <int> INTCONST
+%token INTOFFLOAT
+%token KSTRING
+%token LBRACKET
+%token LEA
+%token LEF
+%token LEI
+%token LET
+%token LOAD
+%token LPAREN
+%token LSL
+%token LSR
+%token LTA
+%token LTF
+%token LTI
+%token MODI
+%token MULF
+%token MULI
+%token NEA
+%token NEF
+%token NEI
+%token OR
+%token <int> POINTER
+%token PROJ
+%token RAISE
+%token RBRACKET
+%token RPAREN
+%token SEQ
+%token SIGNED
+%token SKIP
+%token STAR
+%token STORE
+%token <string> STRING
+%token SUBA
+%token SUBF
+%token SUBI
+%token SWITCH
+%token TRY
+%token UNIT
+%token UNSIGNED
+%token WHILE
+%token WITH
+%token XOR
+%token ADDRAREF
+%token INTAREF
+%token FLOATAREF
+%token ADDRASET
+%token INTASET
+%token FLOATASET
+
+%start phrase
+%type <Cmm.phrase> phrase
+
+%%
+
+phrase:
+    fundecl     { Cfunction $1 }
+  | datadecl    { Cdata $1 }
+  | EOF         { raise End_of_file }
+;
+fundecl:
+    LPAREN FUNCTION STRING LPAREN params RPAREN sequence RPAREN
+      { List.iter (fun (id, ty) -> unbind_ident id) $5;
+        {fun_name = $3; fun_args = $5; fun_body = $7; fun_fast = true} }
+;
+params:
+    oneparam params     { $1 :: $2 }
+  | /**/                { [] }
+;
+oneparam:
+    IDENT COLON machtype { (bind_ident $1, $3) }
+;
+machtype:
+    UNIT                        { [||] }
+  | componentlist               { Array.of_list(List.rev $1) }
+;
+component:
+    ADDR                        { Addr }
+  | INT                         { Int }
+  | FLOAT                       { Float }
+;
+componentlist:
+    component                    { [$1] }
+  | componentlist STAR component { $3 :: $1 }
+;
+expr:
+    INTCONST    { Cconst_int $1 }
+  | FLOATCONST  { Cconst_float $1 }
+  | STRING      { Cconst_symbol $1 }
+  | POINTER     { Cconst_pointer $1 }
+  | IDENT       { Cvar(find_ident $1) }
+  | LBRACKET RBRACKET { Ctuple [] }
+  | LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 }
+  | LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_ident $3, $4) }
+  | LPAREN APPLY expr exprlist machtype RPAREN { Cop(Capply $5, $3 :: List.rev $4) }
+  | LPAREN EXTCALL STRING exprlist machtype RPAREN { Cop(Cextcall($3, $5, false), List.rev $4) }
+  | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3]) }
+  | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4]) }
+  | LPAREN unaryop expr RPAREN { Cop($2, [$3]) }
+  | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4]) }
+  | LPAREN SEQ sequence RPAREN { $3 }
+  | LPAREN IF expr expr expr RPAREN { Cifthenelse($3, $4, $5) }
+  | LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 }
+  | LPAREN WHILE expr sequence RPAREN
+      { let body =
+          match $3 with
+            Cconst_int x when x <> 0 -> $4
+          | _ -> Cifthenelse($3, $4, (Cexit(0,[]))) in
+        Ccatch(0, [], Cloop body, Ctuple []) }
+  | LPAREN CATCH sequence WITH sequence RPAREN { Ccatch(0, [], $3, $5) }
+  | EXIT        { Cexit(0,[]) }
+  | LPAREN TRY sequence WITH bind_ident sequence RPAREN
+                { unbind_ident $5; Ctrywith($3, $5, $6) }
+  | LPAREN ADDRAREF expr expr RPAREN
+      { Cop(Cload Word, [access_array $3 $4 Arch.size_addr]) }
+  | LPAREN INTAREF expr expr RPAREN
+      { Cop(Cload Word, [access_array $3 $4 Arch.size_int]) }
+  | LPAREN FLOATAREF expr expr RPAREN
+      { Cop(Cload Double_u, [access_array $3 $4 Arch.size_float]) }
+  | LPAREN ADDRASET expr expr expr RPAREN
+      { Cop(Cstore Word, [access_array $3 $4 Arch.size_addr; $5]) }
+  | LPAREN INTASET expr expr expr RPAREN
+      { Cop(Cstore Word, [access_array $3 $4 Arch.size_int; $5]) }
+  | LPAREN FLOATASET expr expr expr RPAREN
+      { Cop(Cstore Double_u, [access_array $3 $4 Arch.size_float; $5]) }
+;
+exprlist:
+    exprlist expr               { $2 :: $1 }
+  | /**/                        { [] }
+;
+letdef:
+    oneletdef                   { [$1] }
+  | LPAREN letdefmult RPAREN    { $2 }
+;
+letdefmult:
+    /**/                        { [] }
+  | oneletdef letdefmult        { $1 :: $2 }
+;
+oneletdef:
+    IDENT expr                  { (bind_ident $1, $2) }
+;
+chunk:
+    UNSIGNED BYTE               { Byte_unsigned }
+  | SIGNED BYTE                 { Byte_signed }
+  | UNSIGNED HALF               { Sixteen_unsigned }
+  | SIGNED HALF                 { Sixteen_signed }
+  | UNSIGNED INT32              { Thirtytwo_unsigned }
+  | SIGNED INT32                { Thirtytwo_signed }
+  | INT                         { Word }
+  | ADDR                        { Word }
+  | FLOAT32                     { Single }
+  | FLOAT64                     { Double }
+  | FLOAT                       { Double_u }
+
+;
+unaryop:
+    LOAD chunk                  { Cload $2 }
+  | ALLOC                       { Calloc }
+  | FLOATOFINT                  { Cfloatofint }
+  | INTOFFLOAT                  { Cintoffloat }
+  | RAISE                       { Craise }
+  | ABSF                        { Cabsf }
+;
+binaryop:
+    STORE chunk                 { Cstore $2 }
+  | ADDI                        { Caddi }
+  | SUBI                        { Csubi }
+  | MULI                        { Cmuli }
+  | DIVI                        { Cdivi }
+  | MODI                        { Cmodi }
+  | AND                         { Cand }
+  | OR                          { Cor }
+  | XOR                         { Cxor }
+  | LSL                         { Clsl }
+  | LSR                         { Clsr }
+  | ASR                         { Casr }
+  | EQI                         { Ccmpi Ceq }
+  | NEI                         { Ccmpi Cne }
+  | LTI                         { Ccmpi Clt }
+  | LEI                         { Ccmpi Cle }
+  | GTI                         { Ccmpi Cgt }
+  | GEI                         { Ccmpi Cge }
+  | ADDA                        { Cadda }
+  | SUBA                        { Csuba }
+  | EQA                         { Ccmpa Ceq }
+  | NEA                         { Ccmpa Cne }
+  | LTA                         { Ccmpa Clt }
+  | LEA                         { Ccmpa Cle }
+  | GTA                         { Ccmpa Cgt }
+  | GEA                         { Ccmpa Cge }
+  | ADDF                        { Caddf }
+  | MULF                        { Cmulf }
+  | DIVF                        { Cdivf }
+  | EQF                         { Ccmpf Ceq }
+  | NEF                         { Ccmpf Cne }
+  | LTF                         { Ccmpf Clt }
+  | LEF                         { Ccmpf Cle }
+  | GTF                         { Ccmpf Cgt }
+  | GEF                         { Ccmpf Cge }
+  | CHECKBOUND                  { Ccheckbound }
+;
+sequence:
+    expr sequence               { Csequence($1, $2) }
+  | expr                        { $1 }
+;
+caselist:
+    onecase sequence caselist   { ($1, $2) :: $3 }
+  | /**/                        { [] }
+;
+onecase:
+    CASE INTCONST COLON onecase { $2 :: $4 }
+  | CASE INTCONST COLON         { [$2] }
+;
+bind_ident:
+    IDENT                       { bind_ident $1 }
+;
+datadecl:
+    LPAREN datalist RPAREN      { List.rev $2 }
+;
+datalist:
+    datalist dataitem           { $2 :: $1 }
+  | /**/                        { [] }
+;
+dataitem:
+    STRING COLON                { Cdefine_symbol $1 }
+  | INTCONST COLON              { Cdefine_label $1 }
+  | BYTE INTCONST               { Cint8 $2 }
+  | HALF INTCONST               { Cint16 $2 }
+  | INT INTCONST                { Cint(Nativeint.of_int $2) }
+  | FLOAT FLOATCONST            { Cdouble $2 }
+  | ADDR STRING                 { Csymbol_address $2 }
+  | ADDR INTCONST               { Clabel_address $2 }
+  | KSTRING STRING              { Cstring $2 }
+  | SKIP INTCONST               { Cskip $2 }
+  | ALIGN INTCONST              { Calign $2 }
+;
+
diff --git a/testasmcomp/parsecmmaux.ml b/testasmcomp/parsecmmaux.ml
new file mode 100644
index 00000000..013b4c30
--- /dev/null
+++ b/testasmcomp/parsecmmaux.ml
@@ -0,0 +1,40 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: parsecmmaux.ml,v 1.4 1999/11/17 18:58:43 xleroy Exp $ *)
+
+(* Auxiliary functions for parsing *)
+
+type error =
+    Unbound of string
+
+exception Error of error
+
+let tbl_ident = (Hashtbl.create 57 : (string, Ident.t) Hashtbl.t)
+
+let bind_ident s =
+  let id = Ident.create s in
+  Hashtbl.add tbl_ident s id;
+  id
+
+let find_ident s =
+  try
+    Hashtbl.find tbl_ident s
+  with Not_found ->
+    raise(Error(Unbound s))
+
+let unbind_ident id =
+  Hashtbl.remove tbl_ident (Ident.name id)
+
+let report_error = function
+    Unbound s ->
+      prerr_string "Unbound identifier "; prerr_string s; prerr_endline "."
diff --git a/testasmcomp/parsecmmaux.mli b/testasmcomp/parsecmmaux.mli
new file mode 100644
index 00000000..4636ed01
--- /dev/null
+++ b/testasmcomp/parsecmmaux.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: parsecmmaux.mli,v 1.4 1999/11/17 18:58:43 xleroy Exp $ *)
+
+(* Auxiliary functions for parsing *)
+
+val bind_ident: string -> Ident.t
+val find_ident: string -> Ident.t
+val unbind_ident: Ident.t -> unit
+
+type error =
+    Unbound of string
+
+exception Error of error
+
+val report_error: error -> unit
diff --git a/testasmcomp/power-aix.S b/testasmcomp/power-aix.S
new file mode 100644
index 00000000..c3fce8c8
--- /dev/null
+++ b/testasmcomp/power-aix.S
@@ -0,0 +1,152 @@
+#*********************************************************************
+#*                                                                   *
+#*                          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: power-aix.S,v 1.3 2000/04/05 18:30:22 doligez Exp $
+
+        .csect  .text[PR]
+
+        .globl  .call_gen_code
+.call_gen_code:
+# Save return address
+        mflr 0
+        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, -280(1)
+# Save global pointer
+        stw 2, 20(1)
+# Load code to call
+        lwz 0, 0(3)
+        lwz 2, 4(3)
+        mtlr 0
+# Shuffle arguments
+        mr 3, 4
+        mr 4, 5
+        mr 5, 6
+        mr 6, 7
+# Call the function
+        blrl
+# Restore global pointer
+        lwz 2, 20(1)
+# Deallocate stack frame
+        addic 1, 1, 280
+# 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
+
+        .globl  .caml_c_call
+.caml_c_call:
+# 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
+        mflr    25
+        mr      26, 2
+# Call desired function (descriptor in r11)
+        lwz     0, 0(11)
+        lwz     2, 4(11)
+        mtlr    0
+        blrl
+# Restore return address and RTOC
+        mtlr    25
+        mr      2, 26
+# Return to caller
+        blr
+
+# Function closures
+
+        .globl  call_gen_code
+        .csect  call_gen_code[DS]
+call_gen_code:
+        .long   .call_gen_code, TOC[tc0], 0
+
+        .globl  caml_c_call
+        .csect  caml_c_call[DS]
+caml_c_call:
+        .long   .caml_c_call, TOC[tc0], 0
diff --git a/testasmcomp/power-elf.S b/testasmcomp/power-elf.S
new file mode 100644
index 00000000..cfdceef6
--- /dev/null
+++ b/testasmcomp/power-elf.S
@@ -0,0 +1,131 @@
+/*********************************************************************/
+/*                                                                   */
+/*                          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: power-elf.S,v 1.3 1999/11/17 18:58:43 xleroy Exp $ */
+
+/* Save and restore all callee-save registers */
+/* GPR 14 at sp+16 ... GPR 31 at sp+84
+   FPR 14 at sp+92 ... FPR 31 at sp+228 */
+
+#define Save_callee_save \
+        addic   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)
+
+#define Restore_callee_save \
+        addic   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)
+
+        .section ".text"
+
+        .globl  call_gen_code
+        .type   call_gen_code, @function
+call_gen_code:
+    /* Allocate and link stack frame */
+        stwu    1, -256(1)
+    /* Save return address */
+        mflr    0
+        stw     0, 256+4(1)
+    /* Save all callee-save registers */
+        Save_callee_save
+    /* Shuffle arguments */
+        mtlr    3
+        mr 3, 4
+        mr 4, 5
+        mr 5, 6
+        mr 6, 7
+    /* Call the function */
+        blrl
+    /* Restore callee-save registers */
+        Restore_callee_save
+    /* Reload return address */
+        lwz     0, 256+4(1)
+        mtlr    0
+    /* Return */
+        addi    1, 1, 256
+        blr
+
+        .globl  caml_c_call
+        .type   caml_c_call, @function
+caml_c_call:
+    /* Jump to C function (address in 11) */
+        mtctr   11
+        bctr
diff --git a/testasmcomp/power-rhapsody.S b/testasmcomp/power-rhapsody.S
new file mode 100644
index 00000000..69f2782d
--- /dev/null
+++ b/testasmcomp/power-rhapsody.S
@@ -0,0 +1,129 @@
+/*********************************************************************/
+/*                                                                   */
+/*                          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: power-rhapsody.S,v 1.3 1999/11/17 18:58:44 xleroy Exp $ */
+
+/* Save and restore all callee-save registers */
+/* GPR 14 at sp+16 ... GPR 31 at sp+84
+   FPR 14 at sp+92 ... FPR 31 at sp+228 */
+
+#define Save_callee_save \
+        addic   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)
+
+#define Restore_callee_save \
+        addic   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)
+
+        .text
+
+        .globl  _call_gen_code
+_call_gen_code:
+    /* Allocate and link stack frame */
+        stwu    r1, -256(r1)
+    /* Save return address */
+        mflr    r0
+        stw     r0, 256+4(r1)
+    /* Save all callee-save registers */
+        Save_callee_save
+    /* Shuffle arguments */
+        mtlr    r3
+        mr r3, r4
+        mr r4, r5
+        mr r5, r6
+        mr r6, r7
+    /* Call the function */
+        blrl
+    /* Restore callee-save registers */
+        Restore_callee_save
+    /* Reload return address */
+        lwz     r0, 256+4(r1)
+        mtlr    r0
+    /* Return */
+        addi    r1, r1, 256
+        blr
+
+        .globl  _caml_c_call
+_caml_c_call:
+    /* Jump to C function (address in 11) */
+        mtctr   r11
+        bctr
diff --git a/testasmcomp/quicksort.cmm b/testasmcomp/quicksort.cmm
new file mode 100644
index 00000000..94c1006d
--- /dev/null
+++ b/testasmcomp/quicksort.cmm
@@ -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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: quicksort.cmm,v 1.6 2000/06/25 19:54:50 xleroy Exp $ *)
+
+(function "quicksort" (lo: int hi: int a: addr)
+  (if (< lo hi)
+      (let (i lo
+            j hi
+            pivot (addraref a hi))
+        (while (< i j)
+          (catch
+              (while 1
+                (if (>= i hi) exit [])
+                (if (> (addraref a i) pivot) exit [])
+                (assign i (+ i 1)))
+           with [])
+          (catch
+              (while 1
+                (if (<= j lo) exit [])
+                (if (< (addraref a j) pivot) exit [])
+                (assign j (- j 1)))
+           with [])
+          (if (< i j)
+              (let temp (addraref a i)
+                   (addraset a i (addraref a j))
+                   (addraset a j temp))
+            []))
+        (let temp (addraref a i)
+             (addraset a i (addraref a hi))
+             (addraset a hi temp))
+        (app "quicksort" lo (- i 1) a unit)
+        (app "quicksort" (+ i 1) hi a unit))
+    []))
diff --git a/testasmcomp/quicksort2.cmm b/testasmcomp/quicksort2.cmm
new file mode 100644
index 00000000..3cb14ee7
--- /dev/null
+++ b/testasmcomp/quicksort2.cmm
@@ -0,0 +1,49 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: quicksort2.cmm,v 1.8 2000/06/29 11:45:23 xleroy Exp $ *)
+
+(function "cmp" (i: int j: int)
+  (- i j))
+
+(function "quick" (lo: int hi: int a: addr cmp: addr)
+  (if (< lo hi)
+      (let (i lo
+            j hi
+            pivot (intaref a hi))
+        (while (< i j)
+          (catch
+            (while 1
+              (if (>= i hi) exit [])
+              (if (> (app cmp (intaref a i) pivot int) 0) exit [])
+              (assign i (+ i 1)))
+            with [])
+          (catch
+            (while 1
+              (if (<= j lo) exit [])
+              (if (< (app cmp (intaref a j) pivot int) 0) exit [])
+              (assign j (- j 1)))
+           with [])
+          (if (< i j)
+              (let temp (intaref a i)
+                   (intaset a i (intaref a j))
+                   (intaset a j temp))
+            []))
+        (let temp (intaref a i)
+             (intaset a i (intaref a hi))
+             (intaset a hi temp))
+        (app "quick" lo (- i 1) a cmp unit)
+        (app "quick" (+ i 1) hi a cmp unit))
+    []))
+
+(function "quicksort" (lo: int hi: int a: addr)
+  (app "quick" lo hi a "cmp" unit))
diff --git a/testasmcomp/soli.cmm b/testasmcomp/soli.cmm
new file mode 100644
index 00000000..61100751
--- /dev/null
+++ b/testasmcomp/soli.cmm
@@ -0,0 +1,109 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: soli.cmm,v 1.7 2003/06/30 08:28:48 xleroy Exp $ *)
+
+("d1": int 0 int 1
+ "d2": int 1 int 0
+ "d3": int 0 int -1
+ "d4": int -1 int 0
+ "dir": addr "d1" addr "d2" addr "d3" addr "d4")
+
+("counter": int 0)
+
+(* Out = 0  Empty = 1  Peg = 2 *)
+
+("line0": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0
+ "line1": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
+ "line2": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
+ "line3": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0
+ "line4": int 0 int 2 int 2 int 2 int 1 int 2 int 2 int 2 int 0
+ "line5": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0
+ "line6": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
+ "line7": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
+ "line8": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0
+ "board": addr "line0" addr "line1" addr "line2" addr "line3"
+          addr "line4" addr "line5" addr "line6" addr "line7" addr "line8")
+
+("format": string "%d\n\000")
+
+(function "solve" (m: int)
+  (store int "counter" (+ (load int "counter") 1))
+  (if (== m 31)
+      (== (intaref (addraref "board" 4) 4) 2)
+    (try
+     (if (== (mod (load int "counter") 500) 0)
+          (extcall "printf_int" "format" (load int "counter") unit)
+       [])
+     (let i 1
+       (while (<= i 7)
+         (let j 1
+           (while (<= j 7)
+             (if (== (intaref (addraref "board" i) j) 2)
+                 (seq
+                  (let k 0
+                    (while (<= k 3)
+                      (let (d1 (intaref (addraref "dir" k) 0)
+                            d2 (intaref (addraref "dir" k) 1)
+                            i1 (+ i d1)
+                            i2 (+ i1 d1)
+                            j1 (+ j d2)
+                            j2 (+ j1 d2))
+                        (if (== (intaref (addraref "board" i1) j1) 2)
+                            (if (== (intaref (addraref "board" i2) j2) 1)
+                                (seq
+                                 (intaset (addraref "board" i) j 1)
+                                 (intaset (addraref "board" i1) j1 1)
+                                 (intaset (addraref "board" i2) j2 2)
+                                 (if (app "solve" (+ m 1) int)
+                                     (raise 0a)
+                                   [])
+                                 (intaset (addraref "board" i) j 2)
+                                 (intaset (addraref "board" i1) j1 2)
+                                 (intaset (addraref "board" i2) j2 1))
+                              [])
+                          []))
+                      (assign k (+ k 1)))))
+               [])
+             (assign j (+ j 1))))
+         (assign i (+ i 1))))
+     0
+   with bucket
+     1)))
+
+("format_out": string ".\000")
+("format_empty": string " \000")
+("format_peg": string "$\000")
+("format_newline": string "\n\000")
+
+(function "print_board" ()
+  (let i 0
+    (while (< i 9)
+      (let j 0
+        (while (< j 9)
+          (switch 3 (intaref (addraref "board" i) j)
+            case 0:
+              (extcall "print_string" "format_out" unit)
+            case 1:
+              (extcall "print_string" "format_empty" unit)
+            case 2:
+              (extcall "print_string" "format_peg" unit))
+          (assign j (+ j 1))))
+      (extcall "print_string" "format_newline" unit)
+      (assign i (+ i 1)))))
+
+(function "solitaire" ()
+  (seq
+    (if (app "solve" 0 int)
+        (app "print_board" [] unit)
+      [])
+    0))
diff --git a/testasmcomp/sparc.S b/testasmcomp/sparc.S
new file mode 100644
index 00000000..a2edbf52
--- /dev/null
+++ b/testasmcomp/sparc.S
@@ -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: sparc.S,v 1.2 1999/11/17 18:58:44 xleroy Exp $ */
+
+#ifndef SYS_solaris
+#define Call_gen_code _call_gen_code
+#define Caml_c_call _caml_c_call
+#else
+#define Call_gen_code call_gen_code
+#define Caml_c_call caml_c_call
+#endif
+
+        .global Call_gen_code
+Call_gen_code:
+        save    %sp, -96, %sp
+        mov     %i0, %l0
+        mov     %i1, %i0
+        mov     %i2, %i1
+        mov     %i3, %i2
+        mov     %i4, %i3
+        mov     %i5, %i4
+        call    %l0
+        nop
+        mov     %o0, %i0
+        ret
+        restore
+
+        .global Caml_c_call
+Caml_c_call:
+        jmp     %g4
+        nop
diff --git a/testasmcomp/tagged-fib.cmm b/testasmcomp/tagged-fib.cmm
new file mode 100644
index 00000000..0d10ce24
--- /dev/null
+++ b/testasmcomp/tagged-fib.cmm
@@ -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: tagged-fib.cmm,v 1.4 1999/11/17 18:58:44 xleroy Exp $ *)
+
+(function "fib" (n: int)
+  (if (< n 5)
+      3
+    (-  (+ (app "fib" (- n 2) int) (app "fib" (- n 4) int)) 1)))
+
diff --git a/testasmcomp/tagged-integr.cmm b/testasmcomp/tagged-integr.cmm
new file mode 100644
index 00000000..c42eef79
--- /dev/null
+++ b/testasmcomp/tagged-integr.cmm
@@ -0,0 +1,45 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: tagged-integr.cmm,v 1.5 2000/07/07 14:09:23 xleroy Exp $ *)
+
+("res_square": skip 8)
+("h": skip 8)
+("x": skip 8)
+("s": skip 8)
+("res_integr": skip 8)
+
+(function "square" (x: addr)
+   (let r "res_square"
+        (store float r ( *f (load float x) (load float x)))
+        r))
+
+(function "integr" (f: addr low: addr high: addr n: int)
+  (let (h "h" x "x" s "s" i n)
+    (store float h (/f (-f (load float high) (load float low)) (floatofint n)))
+    (store float x (load float low))
+    (store float s 0.0)
+    (while (> i 0)
+      (store float s (+f (load float s) (load float (app f x addr))))
+      (store float x (+f (load float x) (load float h)))
+      (assign i (- i 1)))
+    (store float "res_integr" ( *f (load float s) (load float h)))
+    "res_integr"))
+
+("low": skip 8)
+("hi": skip 8)
+
+(function "test" (n: int)
+  (store float "low" 0.0)
+  (store float "hi" 1.0)
+  (load float (app "integr" "square" "low" "hi" n addr)))
+
diff --git a/testasmcomp/tagged-quicksort.cmm b/testasmcomp/tagged-quicksort.cmm
new file mode 100644
index 00000000..16727107
--- /dev/null
+++ b/testasmcomp/tagged-quicksort.cmm
@@ -0,0 +1,46 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           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: tagged-quicksort.cmm,v 1.5 2000/06/29 11:45:24 xleroy Exp $ *)
+
+(function "quick" (lo: int hi: int a: addr)
+  (if (< lo hi)
+      (let (i lo
+            j hi
+            pivot (addraref a (>>s hi 1)))
+        (while (< i j)
+          (catch
+              (while 1
+                (if (>= i hi) exit [])
+                (if (> (addraref a (>>s i 1)) pivot) exit [])
+                (assign i (+ i 2)))
+           with [])
+          (catch
+              (while 1
+                (if (<= j lo) exit [])
+                (if (< (addraref a (>>s j 1)) pivot) exit [])
+                (assign j (- j 2)))
+           with [])
+          (if (< i j)
+              (let temp (addraref a (>>s i 1))
+                   (addraset a (>>s i 1) (addraref a (>>s j 1)))
+                   (addraset a (>>s j 1) temp))
+            []))
+        (let temp (addraref a (>>s i 1))
+             (addraset a (>>s i 1) (addraref a (>>s hi 1)))
+             (addraset a (>>s hi 1) temp))
+        (app "quick" lo (- i 2) a unit)
+        (app "quick" (+ i 2) hi a unit))
+    []))
+
+(function "quicksort" (lo: int hi: int a: addr)
+   (app "quick" (+ (<< lo 1) 1) (+ (<< hi 1) 1) a unit))
diff --git a/testasmcomp/tagged-tak.cmm b/testasmcomp/tagged-tak.cmm
new file mode 100644
index 00000000..af3c5c6f
--- /dev/null
+++ b/testasmcomp/tagged-tak.cmm
@@ -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: tagged-tak.cmm,v 1.6 2000/07/07 14:09:23 xleroy Exp $ *)
+
+(function "tak" (x:int y:int z:int)
+  (if (> x y)
+      (app "tak" (app "tak" (- x 2) y z int)
+                 (app "tak" (- y 2) z x int)
+                 (app "tak" (- z 2) x y int) int)
+      z))
+
+(function "takmain" (dummy: int)
+   (app "tak" 37 25 13 int))
diff --git a/testasmcomp/tak.cmm b/testasmcomp/tak.cmm
new file mode 100644
index 00000000..5dcee85d
--- /dev/null
+++ b/testasmcomp/tak.cmm
@@ -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: tak.cmm,v 1.5 2000/06/25 19:54:50 xleroy Exp $ *)
+
+(function "tak" (x:int y:int z:int)
+  (if (> x y)
+      (app "tak" (app "tak" (- x 1) y z int)
+                 (app "tak" (- y 1) z x int)
+                 (app "tak" (- z 1) x y int) int)
+      z))
+
+(function "takmain" (dummy: int)
+   (app "tak" 18 12 6 int))
diff --git a/testlabl/.cvsignore b/testlabl/.cvsignore
new file mode 100644
index 00000000..4c57147b
--- /dev/null
+++ b/testlabl/.cvsignore
@@ -0,0 +1 @@
+*.out *.out2
\ No newline at end of file
diff --git a/testlabl/Makefile b/testlabl/Makefile
new file mode 100644
index 00000000..e3b39cf3
--- /dev/null
+++ b/testlabl/Makefile
@@ -0,0 +1,17 @@
+# $Id: Makefile,v 1.3 2002/06/18 10:47:22 garrigue Exp $
+# Test extensions
+
+CAMLTOP=../boot/ocamlrun ../ocaml -I ../stdlib
+
+test: test-poly
+
+test-poly:
+	TERM=norepeat $(CAMLTOP) < poly.ml > poly.out 2>&1
+	TERM=norepeat $(CAMLTOP) -principal < poly.ml > poly.out2 2>&1
+	@diff poly.exp poly.out && echo ocaml OK || echo ocaml changed
+	@diff poly.exp2 poly.out2 && echo ocaml -principal OK \
+	   || echo ocaml -principal changed
+
+promote:
+	mv poly.out poly.exp
+	mv poly.out2 poly.exp2
diff --git a/testlabl/bugs/yamagata021012.ml b/testlabl/bugs/yamagata021012.ml
new file mode 100644
index 00000000..212a1683
--- /dev/null
+++ b/testlabl/bugs/yamagata021012.ml
@@ -0,0 +1,193 @@
+(* The module begins *)
+exception Out_of_range
+
+class type ['a] cursor =
+  object
+    method get : 'a
+    method incr : unit -> unit
+    method is_last : bool
+  end
+
+class type ['a] storage =
+  object ('self)
+    method first : 'a cursor
+    method len : int
+    method nth : int -> 'a cursor
+    method copy : 'self
+    method sub : int -> int -> 'self
+    method concat : 'a storage -> 'self
+    method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b
+    method iter : ('a -> unit) -> unit
+  end
+
+class virtual ['a, 'cursor] storage_base =
+  object (self : 'self)
+    constraint 'cursor = 'a #cursor
+    method virtual first : 'cursor
+    method virtual len : int
+    method virtual copy : 'self
+    method virtual sub : int -> int -> 'self
+    method virtual concat : 'a storage -> 'self
+    method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b = fun f a0 ->
+      let cur = self#first in
+      let rec loop count a =
+	if count >= self#len then a else
+	let a' = f cur#get count a in
+	cur#incr (); loop (count + 1) a'
+      in
+      loop 0 a0
+    method iter proc =
+      let p = self#first in
+      for i = 0 to self#len - 2 do proc p#get; p#incr () done;
+      if self#len > 0 then proc p#get else ()
+  end
+
+class type ['a] obj_input_channel =
+  object
+    method get : unit -> 'a
+    method close : unit -> unit
+  end
+
+class type ['a] obj_output_channel =
+  object
+    method put : 'a -> unit
+    method flush : unit -> unit
+    method close : unit -> unit
+  end
+
+module UChar =
+struct
+
+  type t = int
+
+  let highest_bit = 1 lsl 30
+  let lower_bits = highest_bit - 1
+
+  let char_of c = 
+    try Char.chr c with Invalid_argument _ ->  raise Out_of_range
+
+  let of_char = Char.code
+
+  let code c =
+    if c lsr 30 = 0
+    then c
+    else raise Out_of_range
+
+  let chr n =
+    if n >= 0 && (n lsr 31 = 0) then n else raise Out_of_range
+
+  let uint_code c = c
+  let chr_of_uint n = n
+
+end
+
+type uchar = UChar.t
+
+let int_of_uchar u = UChar.uint_code u
+let uchar_of_int n = UChar.chr_of_uint n
+
+class type ucursor = [uchar] cursor
+
+class type ustorage = [uchar] storage
+
+class virtual ['ucursor] ustorage_base = [uchar, 'ucursor] storage_base
+
+module UText =
+struct
+
+(* the internal representation is UCS4 with big endian*)
+(* The most significant digit appears first. *)
+let get_buf s i =
+  let n = Char.code s.[i] in
+  let n = (n lsl 8) lor (Char.code s.[i + 1]) in
+  let n = (n lsl 8) lor (Char.code s.[i + 2]) in
+  let n = (n lsl 8) lor (Char.code s.[i + 3]) in
+  UChar.chr_of_uint n
+
+let set_buf s i u =
+  let n = UChar.uint_code u in
+  begin
+    s.[i] <- Char.chr (n lsr 24);
+    s.[i + 1] <- Char.chr (n lsr 16 lor 0xff);
+    s.[i + 2] <- Char.chr (n lsr 8 lor 0xff);
+    s.[i + 3] <- Char.chr (n lor 0xff);
+  end
+
+let init_buf buf pos init =
+  if init#len = 0 then () else
+  let cur = init#first in
+  for i = 0 to init#len - 2 do
+    set_buf buf (pos + i lsl 2) (cur#get); cur#incr ()
+  done;
+  set_buf buf (pos + (init#len - 1) lsl 2) (cur#get)
+
+let make_buf init =
+  let s = String.create (init#len lsl 2) in
+  init_buf s 0 init; s
+
+class text_raw buf =
+  object (self : 'self)
+    inherit [cursor] ustorage_base
+    val contents = buf
+    method first = new cursor (self :> text_raw) 0 
+    method len = (String.length contents) / 4
+    method get i = get_buf contents (4 * i)
+    method nth i = new cursor (self :> text_raw) i
+    method copy = {< contents = String.copy contents >}
+    method sub pos len =
+      {< contents = String.sub contents (pos * 4) (len * 4) >}
+    method concat (text : ustorage) =
+      let buf = String.create (String.length contents + 4 * text#len) in
+      String.blit contents 0 buf 0 (String.length contents);
+      init_buf buf (String.length contents) text;
+      {< contents = buf >}
+  end
+and cursor text i =
+  object
+    val contents = text
+    val mutable pos = i
+    method get = contents#get pos
+    method incr () = pos <- pos + 1
+    method is_last = (pos + 1 >= contents#len)
+  end
+
+class string_raw buf =
+  object
+    inherit text_raw buf
+    method set i u = set_buf contents (4 * i) u
+  end
+
+class text init = text_raw (make_buf init)
+class string init = string_raw (make_buf init)
+
+let of_string s =
+  let buf = String.make (4 * String.length s) '\000' in
+  for i = 0 to String.length s - 1 do
+    buf.[4 * i] <- s.[i]
+  done;
+  new text_raw buf
+
+let make len u =
+  let s = String.create (4 * len) in
+  for i = 0 to len - 1 do set_buf s (4 * i) u done;
+  new string_raw s
+
+let create len = make len (UChar.chr 0)
+
+let copy s = s#copy
+
+let sub s start len = s#sub start len
+
+let fill s start len u =
+  for i = start to start + len - 1 do s#set i u done
+
+let blit src srcoff dst dstoff len =
+  for i = 0 to len - 1 do
+    let u = src#get (srcoff + i) in
+    dst#set (dstoff + i) u
+  done
+
+let concat s1 s2 = s1#concat (s2 (* : #ustorage *) :> uchar storage)
+
+let iter proc s = s#iter proc
+end
diff --git a/testlabl/dirs_multimatch b/testlabl/dirs_multimatch
new file mode 100644
index 00000000..b4495146
--- /dev/null
+++ b/testlabl/dirs_multimatch
@@ -0,0 +1 @@
+parsing typing bytecomp driver toplevel
\ No newline at end of file
diff --git a/testlabl/dirs_poly b/testlabl/dirs_poly
new file mode 100644
index 00000000..3aec606e
--- /dev/null
+++ b/testlabl/dirs_poly
@@ -0,0 +1 @@
+bytecomp byterun driver parsing stdlib tools toplevel typing utils otherlibs/labltk/browser/searchpos.ml
diff --git a/testlabl/mixin.ml b/testlabl/mixin.ml
new file mode 100644
index 00000000..f3339d36
--- /dev/null
+++ b/testlabl/mixin.ml
@@ -0,0 +1,146 @@
+(* $Id: mixin.ml,v 1.3 2003/11/19 02:36:57 garrigue Exp $ *)
+
+open StdLabels
+open MoreLabels
+
+(* Use maps for substitutions and sets for free variables *)
+
+module Subst = Map.Make(struct type t = string let compare = compare end)
+module Names = Set.Make(struct type t = string let compare = compare end)
+
+
+(* Variables are common to lambda and expr *)
+
+type var = [`Var of string]
+
+let subst_var ~subst : var -> _ =
+  function `Var s as x ->
+    try Subst.find s subst
+    with Not_found -> x
+
+let free_var : var -> _ = function `Var s -> Names.singleton s
+
+
+(* The lambda language: free variables, substitutions, and evaluation *)
+
+type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
+
+let free_lambda ~free_rec : _ lambda -> _ = function
+    #var as x -> free_var x
+  | `Abs (s, t) -> Names.remove s (free_rec t)
+  | `App (t1, t2) -> Names.union (free_rec t1) (free_rec t2)
+
+let map_lambda ~map_rec : _ lambda -> _ = function
+    #var as x -> x
+  | `Abs (s, t) as l ->
+      let t' = map_rec t in
+      if t == t' then l else `Abs(s, t')
+  | `App (t1, t2) as l ->
+      let t'1 = map_rec t1 and t'2 = map_rec t2 in
+      if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
+
+let next_id =
+  let current = ref 3 in
+  fun () -> incr current; !current
+
+let subst_lambda ~subst_rec ~free ~subst : _ lambda -> _ = function
+    #var as x -> subst_var ~subst x
+  | `Abs(s, t) as l ->
+      let used = free t in
+      let used_expr =
+        Subst.fold subst ~init:[]
+          ~f:(fun ~key ~data acc ->
+                if Names.mem s used then data::acc else acc) in
+      if List.exists used_expr ~f:(fun t -> Names.mem s (free t)) then
+        let name = s ^ string_of_int (next_id ()) in
+        `Abs(name,
+             subst_rec ~subst:(Subst.add ~key:s ~data:(`Var name) subst) t)
+      else
+        map_lambda ~map_rec:(subst_rec ~subst:(Subst.remove s subst)) l
+  | `App _ as l ->
+      map_lambda ~map_rec:(subst_rec ~subst) l
+
+let eval_lambda ~eval_rec ~subst l =
+  match map_lambda ~map_rec:eval_rec l with
+    `App(`Abs(s,t1), t2) ->
+      eval_rec (subst ~subst:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
+  | t -> t
+
+(* Specialized versions to use on lambda *)
+
+let rec free1 x = free_lambda ~free_rec:free1 x
+let rec subst1 ~subst = subst_lambda ~subst_rec:subst1 ~free:free1 ~subst
+let rec eval1 x = eval_lambda ~eval_rec:eval1 ~subst:subst1 x
+
+
+(* The expr language of arithmetic expressions *)
+
+type 'a expr =
+    [`Var of string | `Num of int | `Add of 'a * 'a
+    | `Neg of 'a | `Mult of 'a * 'a]
+
+let free_expr ~free_rec : _ expr -> _ = function
+    #var as x -> free_var x
+  | `Num _ -> Names.empty
+  | `Add(x, y) -> Names.union (free_rec x) (free_rec y)
+  | `Neg x -> free_rec x
+  | `Mult(x, y) -> Names.union (free_rec x) (free_rec y)
+
+(* Here map_expr helps a lot *)
+let map_expr ~map_rec : _ expr -> _ = function
+    #var as x -> x
+  | `Num _ as x -> x
+  | `Add(x, y) as e ->
+      let x' = map_rec x and y' = map_rec y in
+      if x == x' && y == y' then e
+      else `Add(x', y')
+  | `Neg x as e ->
+      let x' = map_rec x in
+      if x == x' then e else `Neg x'
+  | `Mult(x, y) as e ->
+      let x' = map_rec x and y' = map_rec y in
+      if x == x' && y == y' then e
+      else `Mult(x', y')
+
+let subst_expr ~subst_rec ~subst : _ expr -> _ = function
+    #var as x -> subst_var ~subst x
+  | #expr as e -> map_expr ~map_rec:(subst_rec ~subst) e
+
+let eval_expr ~eval_rec e =
+  match map_expr ~map_rec:eval_rec e with
+    `Add(`Num m, `Num n) -> `Num (m+n)
+  | `Neg(`Num n) -> `Num (-n)
+  | `Mult(`Num m, `Num n) -> `Num (m*n)
+  | #expr as e -> e
+
+(* Specialized versions *)
+
+let rec free2 x = free_expr ~free_rec:free2 x
+let rec subst2 ~subst = subst_expr ~subst_rec:subst2 ~subst
+let rec eval2 x = eval_expr ~eval_rec:eval2 x
+
+
+(* The lexpr language, reunion of lambda and expr *)
+
+type lexpr =
+  [ `Var of string | `Abs of string * lexpr | `App of lexpr * lexpr
+  | `Num of int | `Add of lexpr * lexpr | `Neg of lexpr
+  | `Mult of lexpr * lexpr ]
+
+let rec free : lexpr -> _ = function
+    #lambda as x -> free_lambda ~free_rec:free x
+  | #expr as x -> free_expr ~free_rec:free x
+
+let rec subst ~subst:s : lexpr -> _ = function
+    #lambda as x -> subst_lambda ~subst_rec:subst ~subst:s ~free x
+  | #expr as x -> subst_expr ~subst_rec:subst ~subst:s x
+
+let rec eval : lexpr -> _ = function
+    #lambda as x -> eval_lambda ~eval_rec:eval ~subst x
+  | #expr as x -> eval_expr ~eval_rec:eval x
+
+(* A few examples:
+eval1 (`App(`Abs("x",`Var"x"), `Var"y"));;
+eval2 (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x"));;
+eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5));;
+*)
diff --git a/testlabl/mixin2.ml b/testlabl/mixin2.ml
new file mode 100644
index 00000000..35fe213d
--- /dev/null
+++ b/testlabl/mixin2.ml
@@ -0,0 +1,179 @@
+(* $Id: mixin2.ml,v 1.1 2003/11/19 02:36:57 garrigue Exp $ *)
+
+(* Full fledge version, using objects to structure code *)
+
+open StdLabels
+open MoreLabels
+
+(* Use maps for substitutions and sets for free variables *)
+
+module Subst = Map.Make(struct type t = string let compare = compare end)
+module Names = Set.Make(struct type t = string let compare = compare end)
+
+(* To build recursive objects *)
+
+let lazy_fix make =
+  let rec obj () = make (lazy (obj ()) : _ Lazy.t) in
+  obj ()
+
+let (!!) = Lazy.force
+
+(* The basic operations *)
+
+class type ['a, 'b] ops =
+  object
+    method free : 'b -> Names.t
+    method subst : sub:'a Subst.t -> 'b -> 'a
+    method eval : 'b -> 'a
+  end
+
+(* Variables are common to lambda and expr *)
+
+type var = [`Var of string]
+
+class ['a] var_ops = object (self : ('a, var) #ops)
+  constraint 'a = [> var]
+  method subst ~sub (`Var s as x) =
+    try Subst.find s sub with Not_found -> x
+  method free (`Var s) =
+    Names.singleton s
+  method eval (#var as v) = v
+end
+
+(* The lambda language: free variables, substitutions, and evaluation *)
+
+type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
+
+let next_id =
+  let current = ref 3 in
+  fun () -> incr current; !current
+
+class ['a] lambda_ops (ops : ('a,'a) #ops Lazy.t) =
+  let var : 'a var_ops = new var_ops
+  and free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ('a, 'a lambda) #ops)
+    constraint 'a = [> 'a lambda]
+    method free = function
+        #var as x -> var#free x
+      | `Abs (s, t) -> Names.remove s (!!free t)
+      | `App (t1, t2) -> Names.union (!!free t1) (!!free t2)
+
+    method map ~f = function
+        #var as x -> x
+      | `Abs (s, t) as l ->
+          let t' = f t in
+          if t == t' then l else `Abs(s, t')
+      | `App (t1, t2) as l ->
+          let t'1 = f t1 and t'2 = f t2 in
+          if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | `Abs(s, t) as l ->
+          let used = !!free t in
+          let used_expr =
+            Subst.fold sub ~init:[]
+              ~f:(fun ~key ~data acc ->
+                if Names.mem s used then data::acc else acc) in
+          if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then
+            let name = s ^ string_of_int (next_id ()) in
+            `Abs(name,
+                 !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t)
+          else
+            self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l
+      | `App _ as l ->
+          self#map ~f:(!!subst ~sub) l
+
+    method eval l =
+      match self#map ~f:!!eval l with
+        `App(`Abs(s,t1), t2) ->
+          !!eval (!!subst ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
+      | t -> t
+end
+
+(* Operations specialized to lambda *)
+
+let lambda = lazy_fix (new lambda_ops)
+
+(* The expr language of arithmetic expressions *)
+
+type 'a expr =
+    [ `Var of string | `Num of int | `Add of 'a * 'a
+    | `Neg of 'a | `Mult of 'a * 'a]
+
+class ['a] expr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let var : 'a var_ops = new var_ops
+  and free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ('a, 'a expr) #ops)
+    constraint 'a = [> 'a expr]
+    method free = function
+        #var as x -> var#free x
+      | `Num _ -> Names.empty
+      | `Add(x, y) -> Names.union (!!free x) (!!free y)
+      | `Neg x -> !!free x
+      | `Mult(x, y) -> Names.union (!!free x) (!!free y)
+
+    method map ~f = function
+        #var as x -> x
+      | `Num _ as x -> x
+      | `Add(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Add(x', y')
+      | `Neg x as e ->
+          let x' = f x in
+          if x == x' then e else `Neg x'
+      | `Mult(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Mult(x', y')
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | #expr as e -> self#map ~f:(!!subst ~sub) e
+
+    method eval (#expr as e) =
+      match self#map ~f:!!eval e with
+        `Add(`Num m, `Num n) -> `Num (m+n)
+      | `Neg(`Num n) -> `Num (-n)
+      | `Mult(`Num m, `Num n) -> `Num (m*n)
+      | e -> e
+  end
+
+(* Specialized versions *)
+
+let expr = lazy_fix (new expr_ops)
+
+(* The lexpr language, reunion of lambda and expr *)
+
+type 'a lexpr = [ 'a lambda | 'a expr ]
+
+class ['a] lexpr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let lambda = new lambda_ops ops in
+  let expr = new expr_ops ops in
+  object (self : ('a, 'a lexpr) #ops)
+    constraint 'a = [> 'a lexpr]
+    method free = function
+        #lambda as x -> lambda#free x
+      | #expr as x -> expr#free x
+
+    method subst ~sub = function
+        #lambda as x -> lambda#subst ~sub x
+      | #expr as x -> expr#subst ~sub x
+
+    method eval = function
+        #lambda as x -> lambda#eval x
+      | #expr as x -> expr#eval x
+end
+
+let lexpr = lazy_fix (new lexpr_ops)
+
+(* A few examples:
+lambda#eval (`App(`Abs("x",`Var"x"), `Var"y"));;
+expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x"));;
+lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5));;
+*)
diff --git a/testlabl/mixin3.ml b/testlabl/mixin3.ml
new file mode 100644
index 00000000..2be0bd4e
--- /dev/null
+++ b/testlabl/mixin3.ml
@@ -0,0 +1,173 @@
+(* $Id: mixin3.ml,v 1.1 2003/11/19 02:36:57 garrigue Exp $ *)
+
+(* Full fledge version, using objects to structure code *)
+
+open StdLabels
+open MoreLabels
+
+(* Use maps for substitutions and sets for free variables *)
+
+module Subst = Map.Make(struct type t = string let compare = compare end)
+module Names = Set.Make(struct type t = string let compare = compare end)
+
+(* To build recursive objects *)
+
+let lazy_fix make =
+  let rec obj () = make (lazy (obj ()) : _ Lazy.t) in
+  obj ()
+
+let (!!) = Lazy.force
+
+(* The basic operations *)
+
+class type ['a, 'b] ops =
+  object
+    method free : 'b -> Names.t
+    method subst : sub:'a Subst.t -> 'b -> 'a
+    method eval : 'b -> 'a
+  end
+
+(* Variables are common to lambda and expr *)
+
+type var = [`Var of string]
+
+let var = object (self : ([>var], var) #ops)
+  method subst ~sub (`Var s as x) =
+    try Subst.find s sub with Not_found -> x
+  method free (`Var s) =
+    Names.singleton s
+  method eval (#var as v) = v
+end
+
+(* The lambda language: free variables, substitutions, and evaluation *)
+
+type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
+
+let next_id =
+  let current = ref 3 in
+  fun () -> incr current; !current
+
+let lambda_ops (ops : ('a,'a) #ops Lazy.t) =
+  let free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ([> 'a lambda], 'a lambda) #ops)
+    method free = function
+        #var as x -> var#free x
+      | `Abs (s, t) -> Names.remove s (!!free t)
+      | `App (t1, t2) -> Names.union (!!free t1) (!!free t2)
+
+    method private map ~f = function
+        #var as x -> x
+      | `Abs (s, t) as l ->
+          let t' = f t in
+          if t == t' then l else `Abs(s, t')
+      | `App (t1, t2) as l ->
+          let t'1 = f t1 and t'2 = f t2 in
+          if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | `Abs(s, t) as l ->
+          let used = !!free t in
+          let used_expr =
+            Subst.fold sub ~init:[]
+              ~f:(fun ~key ~data acc ->
+                if Names.mem s used then data::acc else acc) in
+          if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then
+            let name = s ^ string_of_int (next_id ()) in
+            `Abs(name,
+                 !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t)
+          else
+            self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l
+      | `App _ as l ->
+          self#map ~f:(!!subst ~sub) l
+
+    method eval l =
+      match self#map ~f:!!eval l with
+        `App(`Abs(s,t1), t2) ->
+          !!eval (!!subst ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
+      | t -> t
+end
+
+(* Operations specialized to lambda *)
+
+let lambda = lazy_fix lambda_ops
+
+(* The expr language of arithmetic expressions *)
+
+type 'a expr =
+    [ `Var of string | `Num of int | `Add of 'a * 'a
+    | `Neg of 'a | `Mult of 'a * 'a]
+
+let expr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ([> 'a expr], 'a expr) #ops)
+    method free = function
+        #var as x -> var#free x
+      | `Num _ -> Names.empty
+      | `Add(x, y) -> Names.union (!!free x) (!!free y)
+      | `Neg x -> !!free x
+      | `Mult(x, y) -> Names.union (!!free x) (!!free y)
+
+    method private map ~f = function
+        #var as x -> x
+      | `Num _ as x -> x
+      | `Add(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Add(x', y')
+      | `Neg x as e ->
+          let x' = f x in
+          if x == x' then e else `Neg x'
+      | `Mult(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Mult(x', y')
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | #expr as e -> self#map ~f:(!!subst ~sub) e
+
+    method eval (#expr as e) =
+      match self#map ~f:!!eval e with
+        `Add(`Num m, `Num n) -> `Num (m+n)
+      | `Neg(`Num n) -> `Num (-n)
+      | `Mult(`Num m, `Num n) -> `Num (m*n)
+      | e -> e
+  end
+
+(* Specialized versions *)
+
+let expr = lazy_fix expr_ops
+
+(* The lexpr language, reunion of lambda and expr *)
+
+type 'a lexpr = [ 'a lambda | 'a expr ]
+
+let lexpr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let lambda = lambda_ops ops in
+  let expr = expr_ops ops in
+  object (self : ([> 'a lexpr], 'a lexpr) #ops)
+    method free = function
+        #lambda as x -> lambda#free x
+      | #expr as x -> expr#free x
+
+    method subst ~sub = function
+        #lambda as x -> lambda#subst ~sub x
+      | #expr as x -> expr#subst ~sub x
+
+    method eval = function
+        #lambda as x -> lambda#eval x
+      | #expr as x -> expr#eval x
+end
+
+let lexpr = lazy_fix lexpr_ops
+
+(* A few examples:
+lambda#eval (`App(`Abs("x",`Var"x"), `Var"y"));;
+expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x"));;
+lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5));;
+*)
diff --git a/testlabl/multimatch.ml b/testlabl/multimatch.ml
new file mode 100644
index 00000000..4add2210
--- /dev/null
+++ b/testlabl/multimatch.ml
@@ -0,0 +1,157 @@
+(* Simple example *)
+let f x =
+  (multimatch x with `A -> 1 | `B -> true),
+  (multimatch x with `A -> 1. | `B -> "1");;
+
+(* OK *)
+module M : sig
+  val f :
+    [< `A & 'a = int & 'b = float | `B &   'b =string & 'a =  bool] -> 'a * 'b
+end = struct let f = f end;;
+
+(* Bad *)
+module M : sig
+  val f :
+    [< `A & 'a = int & 'b = float | `B &   'b =string & 'a =   int] -> 'a * 'b
+end = struct let f = f end;;
+
+(* Should be good! *)
+module M : sig
+  val f :
+    [< `A & 'a = int * float | `B & 'a = bool * string] -> 'a
+end = struct let f = f end;;
+
+let f = multifun `A|`B as x -> f x;;
+
+(* Two-level example *)
+let f = multifun
+    `A -> (multifun `C -> 1 | `D -> 1.)
+  | `B -> (multifun `C -> true | `D -> "1");;
+
+(* OK *)
+module M : sig
+  val f :
+    [< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a
+     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
+end = struct let f = f end;;
+
+(* Bad *)
+module M : sig
+  val f :
+    [< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a
+     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
+end = struct let f = f end;;
+
+module M : sig
+  val f :
+    [< `A & 'b = [< `C & 'a = int | `D] -> 'a
+     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
+end = struct let f = f end;;
+
+
+(* Examples with hidden sharing *)
+let r = ref []
+let f = multifun `A -> 1 | `B -> true
+let g x = r := [f x];;
+
+(* Bad! *)
+module M : sig
+  val g : [< `A & 'a = int | `B & 'a = bool] -> unit
+end = struct let g = g end;;
+
+let r = ref []
+let f = multifun `A -> r | `B -> ref [];;
+(* Now OK *)
+module M : sig
+  val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
+end = struct let f = f end;;
+(* Still OK *)
+let l : int list ref = r;;
+module M : sig
+  val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
+end = struct let f = f end;;
+
+
+(* Examples that would need unification *)
+let f = multifun `A -> (1, []) | `B -> (true, [])
+let g x = fst (f x);;
+(* Didn't work, now Ok *)
+module M : sig
+  val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a
+end = struct let g = g end;;
+let g = multifun (`A|`B) as x -> g x;;
+
+(* Other examples *)
+
+let f x =
+  let a = multimatch x with `A -> 1 | `B -> "1" in
+  (multifun `A -> print_int | `B -> print_string) x a
+;;
+
+let f = multifun (`A|`B) as x -> f x;;
+
+type unit_op = [`Set of int | `Move of int]
+type int_op = [`Get]
+
+let op r =
+  multifun
+    `Get     -> !r
+  | `Set x   -> r := x
+  | `Move dx -> r := !r + dx
+;;
+
+let rec trace r = function
+    [] -> []
+  | op1 :: ops ->
+      multimatch op1 with
+        #int_op as op1 ->
+          let x = op r op1 in
+          x :: trace r ops
+      | #unit_op as op1 ->
+          op r op1;
+          trace r ops
+;;
+
+class point x = object
+  val mutable x : int = x
+  method get = x
+  method set y = x <- y
+  method move dx = x <- x + dx
+end;;
+
+let poly sort coeffs x =
+  let add, mul, zero =
+    multimatch sort with
+      `Int -> (+), ( * ), 0
+    | `Float -> (+.), ( *. ), 0.
+  in
+  let rec compute = function
+      []     -> zero
+    | c :: cs -> add c (mul x (compute cs))
+  in
+  compute coeffs
+;;
+
+module M : sig
+  val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a
+end = struct let poly = poly end;;
+
+type ('a,'b) num_sort =
+  'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float]
+module M : sig
+  val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a
+end = struct let poly = poly end;;
+
+
+(* type dispatch *)
+
+let print0 = multifun
+    `Int -> print_int
+  | `Float -> print_float
+;;
+let print1 = multifun
+    #num as x -> print0 x
+  | `List t -> List.iter (print0 t)
+  | `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y)
+;;
+print1 (`Pair(`Int,`Float)) (1,1.0);;
diff --git a/testlabl/newlabels.ps b/testlabl/newlabels.ps
new file mode 100644
index 00000000..01eac194
--- /dev/null
+++ b/testlabl/newlabels.ps
@@ -0,0 +1,1458 @@
+%!PS-Adobe-2.0
+%%Creator: dvipsk 5.78 p1.4 Copyright 1996-98 ASCII Corp.(www-ptex@ascii.co.jp)
+%%dvipsk 5.78 Copyright 1998 Radical Eye Software (www.radicaleye.com)
+%%Title: newlabels.dvi
+%%Pages: 2 0
+%%PageOrder: Ascend
+%%BoundingBox: 0 0 596 842
+%%EndComments
+%%BeginProcSet: PStoPS 1 15
+userdict begin
+[/showpage/erasepage/copypage]{dup where{pop dup load
+ type/operatortype eq{1 array cvx dup 0 3 index cvx put
+ bind def}{pop}ifelse}{pop}ifelse}forall
+[/letter/legal/executivepage/a4/a4small/b5/com10envelope
+ /monarchenvelope/c5envelope/dlenvelope/lettersmall/note
+ /folio/quarto/a5]{dup where{dup wcheck{exch{}put}
+ {pop{}def}ifelse}{pop}ifelse}forall
+/setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put}
+ {pop def}ifelse}{def}ifelse
+/PStoPSmatrix matrix currentmatrix def
+/PStoPSxform matrix def/PStoPSclip{clippath}def
+/defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def
+/initmatrix{matrix defaultmatrix setmatrix}bind def
+/initclip[{matrix currentmatrix PStoPSmatrix setmatrix
+ [{currentpoint}stopped{$error/newerror false put{newpath}}
+ {/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse]
+ {[/newpath cvx{/moveto cvx}{/lineto cvx}
+ {/curveto cvx}{/closepath cvx}pathforall]cvx exch pop}
+ stopped{$error/errorname get/invalidaccess eq{cleartomark
+ $error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop
+ /initclip dup load dup type dup/operatortype eq{pop exch pop}
+ {dup/arraytype eq exch/packedarraytype eq or
+  {dup xcheck{exch pop aload pop}{pop cvx}ifelse}
+  {pop cvx}ifelse}ifelse
+ {newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def
+/initgraphics{initmatrix newpath initclip 1 setlinewidth
+ 0 setlinecap 0 setlinejoin []0 setdash 0 setgray
+ 10 setmiterlimit}bind def
+end
+%%EndProcSet
+%DVIPSCommandLine: dvips -f newlabels
+%DVIPSParameters: dpi=300
+%DVIPSSource:  TeX output 1999.10.26:1616
+%%BeginProcSet: tex.pro
+%!
+/TeXDict 300 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
+/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
+mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
+ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
+isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
+hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
+TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if}
+forall round exch round exch]setmatrix}N /@landscape{/isls true N}B
+/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B
+/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{
+/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N
+string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N
+end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{
+/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]
+N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup
+length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{
+128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub
+get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data
+dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N
+/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup
+/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx
+0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff
+setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff
+.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}
+if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup
+length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{
+cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin
+0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul
+add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict
+/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook
+known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
+/IE 256 array N 2 string 0 1 255{IE S dup 360 add 36 4 index cvrs cvn
+put}for pop 65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N
+/RMat[1 0 0 -1 0 0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley
+X /rulex X V}B /V{}B /RV statusdict begin /product where{pop false[
+(Display)(NeXT)(LaserWriter 16/600)]{dup length product length le{dup
+length product exch 0 exch getinterval eq{pop true exit}if}{pop}ifelse}
+forall}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false
+RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1
+false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform
+round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg
+rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail
+{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}
+B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{
+4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{
+p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p
+a}B /bos{/SS save N}B /eos{SS restore}B end
+
+%%EndProcSet
+TeXDict begin 39158280 55380996 1000 300 300 (newlabels.dvi)
+@start
+%DVIPSBitmapFont: Fa cmr6 6 2
+/Fa 2 51 df<187898181818181818181818181818FF08107D8F0F> 49
+D<1F00618040C08060C0600060006000C00180030006000C00102020207FC0FFC00B107F
+8F0F> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fb cmmi8 8 4
+/Fb 4 111 df<FFC0FF1C00181C00101C00101C00103800203800203800203800207000
+40700040700040700040E00080E00080E00080E00080E00100E00200E004006008003830
+000FC00018177E9618> 85 D<0300038003000000000000000000000000001C00240046
+0046008C000C0018001800180031003100320032001C0009177F960C> 105
+D<383C1E0044C6630047028100460301008E0703000C0603000C0603000C060300180C06
+00180C0620180C0C20180C0C40301804C0301807001B0E7F8D1F> 109
+D<383C0044C6004702004602008E06000C06000C06000C0600180C00180C401818401818
+80300980300E00120E7F8D15> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fc cmbx8 8 4
+/Fc 4 111 df<01800780FF80FF80078007800780078007800780078007800780078007
+800780078007800780FFF8FFF80D157D9414> 49 D<387C7C7C3800000000FCFC3C3C3C
+3C3C3C3C3C3C3C3CFFFF08187F970B> 105 D<FC7E0FC0FD8730E03E07C0F03E07C0F03C
+0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F0FF
+1FE3FCFF1FE3FC1E0F7E8E23> 109 D<FC7C00FD8E003E0F003E0F003C0F003C0F003C0F
+003C0F003C0F003C0F003C0F003C0F003C0F00FF3FC0FF3FC0120F7E8E17> I
+E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fd cmsy8 8 3
+/Fd 3 93 df<FFFFF0FFFFF014027D881B> 0 D<020002000200C218F2783AE00F800F80
+3AE0F278C2180200020002000D0E7E8E12> 3 D<03F8001FFF003C07806000C0C00060C0
+0060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C0
+006040002013137E9218> 92 D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fe cmtt12 12 43
+/Fe 43 125 df<01818003C3C003C3C003C3C003C3C003C3C003C3C07FFFF0FFFFF8FFFF
+F87FFFF00787800787800787800F8F800F0F000F0F000F0F000F0F007FFFF0FFFFF8FFFF
+F87FFFF01E1E001E1E001E1E001E1E001E1E001E1E000C0C00151E7E9D1A> 35
+D<00E00003F00007F8000738000E1C000E1C000E1C000E1C000E38000E39FC0E71FC07F1
+FC07E1C007C1C00781C00783800F83801FC3803DC70078E70070EE00E07E00E07E00E03C
+08E03C1CE07E1C70FF1C7FE7F83FC3F80F00E0161E7F9D1A> 38
+D<0038007800F001E003C007800F000E001C001C0038003800700070007000E000E000E0
+00E000E000E000E000E000E000E000700070007000380038001C001C000E000F00078003
+C001E000F8007800380D2878A21A> 40 D<6000F00078003C001E000F000780038001C0
+01C000E000E0007000700070003800380038003800380038003800380038003800700070
+007000E000E001C001C0038007800F001E003C007800F00060000D287CA21A> I<7FFFC0
+FFFFE0FFFFE07FFFC013047D901A> 45 D<00C001C001C003C007C00FC07FC0FDC071C0
+01C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C0
+7FFF7FFF7FFF101E7B9D1A> 49 D<03F8000FFE001FFF803C07C07801E07000E0E00070
+F00070F000706000700000700000700000E00000E00001C00003C0000780000F00001E00
+003C0000780000F00003E00007C0000F00001E00703C00707FFFF0FFFFF07FFFF0141E7D
+9D1A> I<03FC000FFF003FFFC03C03E07800E07800707800700000700000700000E00001
+E00007C003FF8003FF0003FFC00003E00000E0000070000078000038000038600038F000
+38F00078E000707000E07E03E03FFFC00FFF0001FC00151E7E9D1A> I<01FC0007FF001F
+FFC01F07C03C01E07800F07000707000707000707800F03800E01E03C00FFF8003FE0007
+FF001F8FC03C01E07800F0700070E00038E00038E00038E00038F000787000707800F03E
+03E01FFFC007FF0001FC00151E7E9D1A> 56 D<01F00007FC001FFE003E0F0038078070
+03807001C0E001C0E001C0E001E0E000E0E000E0E001E07001E07803E03C0FE01FFFE00F
+FCE003F0E00001C00001C00001C0000380600380F00700F00F00F03E007FFC003FF0000F
+C000131E7D9D1A> I<3078FCFC78300000000000000000003078FCFC7830061576941A>
+I<183C7E7E3C18000000000000000000183C7E7E3E1E0E0E1C3CF8F060071C77941A> I<
+0000C00003E00007E0000FC0003F80007E0000FC0003F80007E0000FC0003F80007E0000
+FC0000FC00007E00003F80000FC00007E00003F80000FC00007E00003F80000FC00007E0
+0003E00000C0131A7D9B1A> I<7FFFF0FFFFF8FFFFF87FFFF00000000000000000000000
+007FFFF0FFFFF8FFFFF87FFFF0150C7E941A> I<600000F80000FC00007E00003F80000F
+C00007E00003F80000FC00007E00003F80000FC00007E00007E0000FC0003F80007E0000
+FC0003F80007E0000FC0003F80007E0000FC0000F80000600000131A7D9B1A> I<007C38
+01FF3807FFF80F83F81E00F81C0078380078380038700038700038700000E00000E00000
+E00000E00000E00000E00000E00000E000007000007000387000383800383800381C0070
+1E00F00F83E007FFC001FF80007C00151E7E9D1A> 67 D<FE03FEFF03FEFF03FE1D8070
+1D80701DC0701CC0701CC0701CE0701CE0701C60701C70701C70701C30701C38701C3870
+1C18701C1C701C1C701C0C701C0E701C0E701C06701C06701C07701C03701C0370FF81F0
+FF81F0FF80F0171E7F9D1A> 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0
+E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070
+000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E
+9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800
+003800003800003800003800003800003800003800003800003800003800003800003800
+00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I<FFFCFFFCFF
+FCE000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E0
+00E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000FFFCFFFCFF
+FC0E2776A21A> 91 D<FFFCFFFCFFFC001C001C001C001C001C001C001C001C001C001C
+001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C
+001C001C001C001C001CFFFCFFFCFFFC0E277FA21A> 93 D<1FF0003FFC007FFE00780F
+00300700000380000380007F8007FF801FFF803F8380780380700380E00380E00380E003
+80700780780F803FFFFC1FFDFC07F0FC16157D941A> 97 D<7E0000FE00007E00000E00
+000E00000E00000E00000E00000E00000E3E000EFF800FFFE00FC1F00F80700F00380E00
+380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
+C00EFF80063E00161E7F9D1A> I<00FF8003FFC00FFFE01F01E03C00C078000070000070
+0000E00000E00000E00000E00000E000007000007000007800703C00701F01F00FFFE003
+FFC000FE0014157D941A> I<000FC0001FC0000FC00001C00001C00001C00001C00001C0
+0001C001F1C007FDC00FFFC01E0FC03C07C07803C07001C0E001C0E001C0E001C0E001C0
+E001C0E001C0E001C07003C07003C03807C03E0FC01FFFF807FDFC01F1F8161E7E9D1A>
+I<01F80007FF000FFF801E07C03C01C07800E07000E0E00070E00070FFFFF0FFFFF0FFFF
+F0E000007000007000007800703C00701F01F00FFFE003FF8000FE0014157D941A> I<00
+07E0001FF0003FF800787800F03000E00000E00000E00000E0007FFFF0FFFFF0FFFFF000
+E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000
+E00000E00000E0003FFF807FFFC03FFF80151E7F9D1A> I<7E0000FE00007E00000E0000
+0E00000E00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E0
+0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FC
+FFE7FE7FC3FC171E7F9D1A> 104 D<00C00001E00001E00000C000000000000000000000
+0000000000000000007FE0007FE0007FE00000E00000E00000E00000E00000E00000E000
+00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFF80FFFFC07FFF80
+121F7C9E1A> I<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0131E7D9D1A> 108
+D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C001C1C1C
+001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C
+007F1F1F00FFBFBF807F1F1F00191580941A> I<7E3E00FEFF807FFFC00FC1C00F80E00F
+00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E
+00E07FC3FCFFE7FE7FC3FC17157F941A> I<01F00007FC001FFF003E0F803C07807803C0
+7001C0E000E0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F80
+1FFF0007FC0001F00013157D941A> I<7E3E00FEFF807FFFE00FC1F00F80700F00380E00
+380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
+C00EFF800E3E000E00000E00000E00000E00000E00000E00000E00000E00007FC000FFE0
+007FC00016207F941A> I<7F81F8FF8FFC7F9FFE03FE1E03F80C03E00003E00003C00003
+80000380000380000380000380000380000380000380000380000380007FFF00FFFF007F
+FF0017157F941A> 114 D<07FB801FFF807FFF80780780E00380E00380E003807800007F
+C0001FFC0007FE00003F800007806001C0E001C0E001C0F003C0FC0780FFFF00EFFE00E3
+F80012157C941A> I<0180000380000380000380000380000380000380007FFFE0FFFFE0
+FFFFE0038000038000038000038000038000038000038000038000038000038000038070
+03807003807003807001C1E001FFE000FF80003F00141C7F9B1A> I<7E07E0FE0FE07E07
+E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00
+E00E00E00E01E00F03E007FFFC03FFFE00FCFC17157F941A> I<7F83FCFFC7FE7F83FC0E
+00E00E00E00E00E00701C00701C00701C003838003838003838001C70001C70001C70000
+EE0000EE0000EE00007C00007C0000380017157F941A> I<FF83FEFF83FEFF83FE380038
+3800381C00701C00701C00701C38701C7C701C7C700C6C600EEEE00EEEE00EEEE00EEEE0
+0EC6E006C6C007C7C00783C00783C017157F941A> I<7FC7F87FCFFC7FC7F80703C00383
+8003C70001EF0000FE00007C00007800003800007C0000EE0001EE0001C7000383800783
+C00F01C07FC7FCFFC7FE7FC7FC17157F941A> I<7F83FCFFC7FE7F83FC0E00E00E00E007
+00E00701C00701C00381C003838003C38001C38001C70000E70000E70000E60000660000
+6E00003C00003C00003C0000380000380000380000700000700030F00078E00071E0007F
+C0003F80001E000017207F941A> I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0
+F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F060042775A21A> 124 D
+E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Ff cmr8 8 3
+/Ff 3 51 df<003000003000003000003000003000003000003000003000003000003000
+003000FFFFFCFFFFFC003000003000003000003000003000003000003000003000003000
+00300000300016187E931B> 43 D<06000E00FE000E000E000E000E000E000E000E000E
+000E000E000E000E000E000E000E000E000E00FFE00B157D9412> 49
+D<0F8030E040708030C038E0384038003800700070006000C00180030006000C08080810
+183FF07FF0FFF00D157E9412> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fg cmmi12 12 13
+/Fg 13 121 df<0FFFF81FFFFC3FFFF870200040200080200080600000600000600000C0
+0000C00000C00000C00001C0000180000180000380000380000380000700000300001615
+7E9415> 28 D<0000100000002000000020000000200000002000000040000000400000
+004000000040000000800000008000000080000000800000010000000FE00000711C0001
+C10600030203000E0203801C020180180201C0380401C0700401C0700401C0700401C0E0
+080380E0080380E00807006008070070100E0030101C00301038001C10E0000623800001
+FE0000002000000020000000400000004000000040000000400000008000000080000000
+800000008000001A2D7EA21D> 30 D<70F8F8F87005057C840E> 58
+D<70F8FCFC7404040404080810102040060F7C840E> I<00008000018000018000030000
+0300000300000600000600000600000C00000C00000C0000180000180000180000300000
+300000300000600000600000600000C00000C00000C00001800001800001800001800003
+00000300000300000600000600000600000C00000C00000C000018000018000018000030
+0000300000300000600000600000600000C00000C00000C0000011317DA418> 61
+D<00FFFC00000F8000000F0000000F0000001E0000001E0000001E0000001E0000003C00
+00003C0000003C0000003C00000078000000780000007800000078000000F0000000F000
+0000F0000000F0000001E0000001E0000001E0002001E0002003C0004003C0004003C000
+8003C0008007800180078001000780030007800F000F803E00FFFFFE001B227DA121> 76
+D<1FFFFFFE1E01E00E1801E0063001E0062003C0062003C0064003C0044003C004400780
+04800780048007800400078000000F0000000F0000000F0000000F0000001E0000001E00
+00001E0000001E0000003C0000003C0000003C0000003C00000078000000780000007800
+000078000000F0000000F0000000F0000000F0000001F000007FFFC0001F227EA11D> 84
+D<3FFE01FF8003C0003C0003C000300003C0001000078000200007800020000780002000
+07800020000F000040000F000040000F000040000F000040001E000080001E000080001E
+000080001E000080003C000100003C000100003C000100003C0001000078000200007800
+020000780002000078000200007000040000F000040000F0000800007000080000700010
+00007000200000380040000038008000001C01000000060600000001F800000021237DA1
+21> I<007E000381000700800E00801C0080380080780100700600FFF800F00000F00000
+E00000E00000E00000E00000E00080E000807003003004001838000FC00011157D9417>
+101 D<01E00FC001C001C001C0038003800380038007000700070007000E000E000E000E
+001C001C001C001C0038003800380038007000700070007080E100E100E100620062003C
+000B237EA20F> 108 D<03C0F004631C04740E08780E08700708700708700F00E00F00E0
+0F00E00F00E00F01C01E01C01E01C01E01C03C03803803803803C07003C0E0072180071E
+000700000700000E00000E00000E00000E00001C00001C00001C0000FF8000181F819418
+> 112 D<3C0F004630C04741C08783C08783C08701808700000E00000E00000E00000E00
+001C00001C00001C00001C000038000038000038000038000070000030000012157E9416
+> 114 D<01E0F006310C081A1C101A3C201C3C201C18201C000038000038000038000038
+0000700000700000700000700860E010F0E010F0E020E170404230803C1F0016157E941C
+> 120 D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fh cmti12 12 22
+/Fh 22 122 df<FFF0FFF0FFE00C037C8B11> 45 D<70F8F8F0E005057A840F> I<00F8
+C00185C00705C00E03800E03801C03803C0380380700780700780700780700F00E00F00E
+00F00E00F00E10F01C20701C20703C20305C40308C400F078014157B9419> 97
+D<03C01F8003800380038007000700070007000E000E000E000E001C001CF81D0C1E0E3C
+0638073807380F700F700F700F700FE01EE01EE01EE03CE038E038607060E031C01F0010
+237BA216> I<007E0001C1000301800703800E07801C07803C0000380000780000780000
+780000F00000F00000F00000F00000F00100700100700200300C001830000FC00011157B
+9416> I<00003C0003F80000380000380000380000700000700000700000700000E00000
+E00000E00000E00001C000F9C00185C00705C00E03800E03801C03803C03803807007807
+00780700780700F00E00F00E00F00E00F00E10F01C20701C20703C20305C40308C400F07
+8016237BA219> I<00F803840E021C023C0238027804F018FFE0F000F000E000E000E000
+E000E002E0026004701830600F800F157A9416> I<00003E0000470000CF00018F000186
+000380000380000380000700000700000700000700000700000E0000FFF0000E00000E00
+000E00001C00001C00001C00001C00001C00003800003800003800003800003800007000
+00700000700000700000700000E00000E00000E00000E00000C00001C00001C000718000
+F18000F300006200003C0000182D82A20F> I<001F180030B800E0B801C07001C0700380
+700780700700E00F00E00F00E00F00E01E01C01E01C01E01C01E01C01E03800E03800E07
+80060B8006170001E700000700000700000E00000E00000E00701C00F01800F0300060E0
+003F8000151F7E9416> I<00C001E001C001C0000000000000000000000000000000001E
+002300430043008700870087000E000E001C001C001C0038003800384070807080708071
+0032001C000B217BA00F> 105 D<00F00007E00000E00000E00000E00001C00001C00001
+C00001C0000380000380000380000380000700000701E00702100704700E08F00E10F00E
+20600E40001D80001E00001FC0001C7000383800383800381C00381C2070384070384070
+3840701880E01880600F0014237DA216> 107 D<01E00FC001C001C001C0038003800380
+038007000700070007000E000E000E000E001C001C001C001C0038003800380038007000
+700070007100E200E200E200E200640038000B237CA20C> I<1C0F80F8002610C10C0047
+6066060087807807008780780700870070070087007007000E00E00E000E00E00E000E00
+E00E000E00E00E001C01C01C001C01C01C001C01C01C001C01C038203803803840380380
+70403803807080380380308070070031003003001E0023157B9428> I<380F804C30C04E
+40608E80708F00708E00708E00701C00E01C00E01C00E01C00E03801C03801C03801C038
+0384700388700308700708700310E003106001E016157B941B> I<007E0001C300038180
+0701C00E01C01C01E03C01E03801E07801E07801E07801E0F003C0F003C0F00380F00780
+700700700E00700C0030180018700007C00013157B9419> I<01C1F002621804741C0878
+0C08700E08700E08701E00E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0780380
+7003807003C0E003C1C0072380071E000700000700000E00000E00000E00000E00001C00
+001C00001C0000FFC000171F7F9419> I<1C1F002620804741C08783C08703C087018087
+00000E00000E00000E00000E00001C00001C00001C00001C000038000038000038000038
+000070000030000012157B9415> 114 D<00FC000183000200800401800C03800C03000C
+00000F00000FF00007FC0003FE00003E00000F00000700700700F00600F00600E0040040
+08002030001FC00011157D9414> I<00C001C001C001C001C003800380038003800700FF
+F8070007000E000E000E000E001C001C001C001C00380038003800381070207020704070
+8031001E000D1F7C9E10> I<1E0060E02300E0F04380E1F04381C0F08381C0708701C030
+8701C030070380200E0380200E0380200E0380201C0700401C0700401C0700401C070080
+1C0700801C0701001C0F01000C0B02000613840003E0F8001C157B9420> 119
+D<03C1E0046210083470103CF02038F020386020380000700000700000700000700000E0
+0000E00000E00000E02061C040F1C040F1C080E2C100446200383C0014157D9416> I<1E
+00302300704380704380E08380E08700E08700E00701C00E01C00E01C00E01C01C03801C
+03801C03801C03801C07001C07001C07001C0F000C3E0003CE00000E00000E00001C0060
+1C00F03800F03000E0600080C0004380003E0000141F7B9418> I
+E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fi cmbx12 12 20
+/Fi 20 122 df<FFFFFF8000FFFFFFF00007F003FC0007F0007E0007F0003F0007F0001F
+8007F0000FC007F00007E007F00007E007F00007F007F00003F007F00003F007F00003F0
+07F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807
+F00003F807F00003F807F00003F007F00003F007F00003F007F00007E007F00007E007F0
+000FC007F0001F8007F0003F0007F0007E0007F003FC00FFFFFFF000FFFFFF800025227E
+A12B> 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006
+FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F
+00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80
+18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003
+F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8
+00000003F800000003F800000003F800000003F800000003F800000003F800000003F800
+000003F800000003F800000003F800000003F800000003F800000003F800000003F80000
+0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022
+227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0
+03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F
+18167E951B> 97 D<FF000000FF0000001F0000001F0000001F0000001F0000001F0000
+001F0000001F0000001F0000001F0000001F0000001F0000001F0FE0001F3FF8001FE07C
+001F803E001F001F001F000F801F000F801F000FC01F000FC01F000FC01F000FC01F000F
+C01F000FC01F000FC01F000FC01F000F801F001F801F801F001FC03E001EE07C001C3FF8
+00180FC0001A237EA21F> I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000
+FC0000FC0000FC0000FC0000FC0000FC00007C00007E00007E00003E00181F00300FC060
+07FFC000FF0015167E9519> I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00
+F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC0
+7003FFC000FF0015167E951A> 101 D<001FC0007FE000F1F001E3F003E3F007C3F007C1
+E007C00007C00007C00007C00007C00007C000FFFE00FFFE0007C00007C00007C00007C0
+0007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C0
+0007C00007C0003FFC003FFC00142380A211> I<01FE0F0007FFBF800F87C7801F03E780
+1E01E0003E01F0003E01F0003E01F0003E01F0003E01F0001E01E0001F03E0000F87C000
+0FFF800009FE000018000000180000001C0000001FFFE0000FFFF80007FFFE001FFFFF00
+3C003F0078000F80F0000780F0000780F0000780F000078078000F003C001E001F007C00
+0FFFF80001FFC00019217F951C> I<1C003E007F007F007F003E001C0000000000000000
+00000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F001F001F00FFE0FFE00B247EA310> 105 D<FF00FF001F001F001F001F00
+1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
+1F001F001F001F001F001F001F001F001F00FFE0FFE00B237EA210> 108
+D<FF07F007F000FF1FFC1FFC001F303E303E001F403E403E001F801F801F001F801F801F
+001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F001F001F001F00FFE0FFE0FFE0FFE0FFE0FFE02B167E9530> I<FF07E000
+FF1FF8001F307C001F403C001F803E001F803E001F003E001F003E001F003E001F003E00
+1F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E00
+1F003E00FFE1FFC0FFE1FFC01A167E951F> I<00FE0007FFC00F83E01E00F03E00F87C00
+7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00
+F81F01F00F83E007FFC000FE0017167E951C> I<FF0FE000FF3FF8001FE07C001F803E00
+1F001F001F001F801F001F801F000FC01F000FC01F000FC01F000FC01F000FC01F000FC0
+1F000FC01F000FC01F001F801F001F801F803F001FC03E001FE0FC001F3FF8001F0FC000
+1F0000001F0000001F0000001F0000001F0000001F0000001F0000001F000000FFE00000
+FFE000001A207E951F> I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F
+E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF
+FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007
+80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F
+80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000
+F80011207F9F16> I<FF01FE00FF01FE001F003E001F003E001F003E001F003E001F003E
+001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E
+001F003E001F007E001F00FE000F81BE0007FF3FC001FC3FC01A167E951F> I<FFE07FC0
+FFE07FC00F801C0007C0380003E0700003F0600001F8C00000F98000007F8000003F0000
+001F0000001F8000003FC0000037C0000063E00000C1F00001C0F8000380FC0007007E00
+0E003E00FF80FFE0FF80FFE01B167F951E> 120 D<FFE01FE0FFE01FE01F8007000F8006
+000FC00E0007C00C0007E00C0003E0180003E0180001F0300001F0300000F8600000F860
+00007CC000007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E00
+00000C0000000C00000018000078180000FC380000FC300000FC60000069C000007F8000
+001F0000001B207F951E> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fj cmsy10 12 15
+/Fj 15 107 df<FFFFFFFCFFFFFFFC1E027C8C27> 0 D<03F0000FFC001FFE003FFF007F
+FF807FFF80FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803F
+FF001FFE000FFC0003F00012147D9519> 15 D<000FFFFC007FFFFC01F0000003800000
+060000000C0000001800000030000000300000006000000060000000C0000000C0000000
+C0000000C0000000C0000000C0000000C0000000C0000000600000006000000030000000
+30000000180000000C000000060000000380000001E00000007FFFFC001FFFFC1E1E7C9A
+27> 26 D<00000001800000000001800000000001800000000001800000000000C00000
+000000C000000000006000000000003000000000003000000000001C00000000000E0000
+0000000700FFFFFFFFFFE0FFFFFFFFFFE0000000000700000000000E00000000001C0000
+000000300000000000300000000000600000000000C00000000000C00000000001800000
+00000180000000000180000000000180002B1A7D9832> 33 D<001FFF007FFF01E00003
+80000600000C0000180000300000300000600000600000600000C00000C00000FFFFFFFF
+FFFFC00000C000006000006000006000003000003000001800000C000006000003800001
+E000007FFF001FFF181E7C9A21> 50 D<00000300000300000600000600000C00000C00
+00180000180000300000300000600000600000C00000C00000C000018000018000030000
+0300000600000600000C00000C0000180000180000300000300000600000600000C00000
+C0000180000180000300000300000300000600000600000C00000C000018000018000030
+0000300000600000600000C00000400000183079A300> 54 D<C0C0C0C0C0C0C0C0E0E0
+C0C0C0C0C0C0C0C003127D9400> I<00008000018001F980070F000C0300180380180780
+3006C03006C0700CE0600C60600C60600C60E01870E01870E01870E03070E03070E03070
+E06070E06070E06070E06070E0C070E0C070E0C070E18070E180706180606300607300E0
+7300E03300C03600C01E01801E01800C03000F0E000DF800180000180000180000142A7E
+A519> 59 D<000100000003000000030000000300000003000000030000000300000003
+000000030000000300000003000000030000000300000003000000030000000300000003
+000000030000000300000003000000030000000300000003000000030000000300000003
+000000030000000300000003000000030000FFFFFFFEFFFFFFFE1F207C9F27> 63
+D<40000040C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
+C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
+C0C00000C0C00000C0C00000C0C00000C0C00000C0600001806000018030000300180006
+000E001C000780780001FFE000007F80001A1F7D9D21> 91 D<007F800001FFE0000780
+78000E001C0018000600300003006000018060000180C00000C0C00000C0C00000C0C000
+00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
+00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
+00C0400000401A1F7D9D21> I<000C0000000C0000001E0000001E0000001E0000003300
+0000330000006180000061800000C0C00000C0C00000C0C0000180600001806000030030
+00030030000300300006001800060018000C000C000C000C000C000C0018000600180006
+003000030030000300600001806000018060000180C00000C0C00000401A1F7D9D21> 94
+D<0003C0001E0000380000700000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00001C0000380000F00
+00F800000F000003800001C00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E000007000003800001E
+000003C012317DA419> 102 D<F800000F000003800001C00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E000007000003800001E000003C0001E0000380000700000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00001C0000380000F0000F8000012317DA419> I<C0C0C0C0C0C0C0C0C0C0C0C0C0
+C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0
+02317AA40E> 106 D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fk cmr12 12 65
+/Fk 65 125 df<001FC1F00070371800C03E3C01807C3C0380783C070038000700380007
+003800070038000700380007003800070038000700380007003800FFFFFFC00700380007
+003800070038000700380007003800070038000700380007003800070038000700380007
+0038000700380007003800070038000700380007003800070038000700380007003C007F
+E1FFC01E2380A21C> 11 D<001FC0000070200000C01000018038000380780007007800
+0700300007000000070000000700000007000000070000000700000007000000FFFFF800
+070078000700380007003800070038000700380007003800070038000700380007003800
+070038000700380007003800070038000700380007003800070038000700380007003800
+070038007FE1FF80192380A21B> I<001FD8000070380000C07800018078000380780007
+0038000700380007003800070038000700380007003800070038000700380007003800FF
+FFF800070038000700380007003800070038000700380007003800070038000700380007
+003800070038000700380007003800070038000700380007003800070038000700380007
+003800070038007FF3FF80192380A21B> I<000FC07F00007031C08000E00B004001801E
+00E003803E01E007003C01E007001C00C007001C000007001C000007001C000007001C00
+0007001C000007001C000007001C0000FFFFFFFFE007001C01E007001C00E007001C00E0
+07001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007
+001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E00700
+1C00E007001C00E07FF1FFCFFE272380A229> I<70F8FCFC740404040408081010204006
+0F7CA20E> 39 D<00200040008001000300060004000C000C0018001800300030003000
+7000600060006000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
+6000600060007000300030003000180018000C000C000400060003000100008000400020
+0B327CA413> I<800040002000100018000C000400060006000300030001800180018001
+C000C000C000C000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
+C000C000C001C0018001800180030003000600060004000C00180010002000400080000B
+327DA413> I<70F8FCFC7404040404080810102040060F7C840E> 44
+D<FFF8FFF80D02808B10> I<70F8F8F87005057C840E> I<01F000071C000C0600180300
+3803803803807001C07001C07001C07001C0F001E0F001E0F001E0F001E0F001E0F001E0
+F001E0F001E0F001E0F001E0F001E0F001E0F001E0F001E07001C07001C07001C07803C0
+3803803803801C07000C0600071C0001F00013227EA018> 48 D<008003800F80F38003
+800380038003800380038003800380038003800380038003800380038003800380038003
+800380038003800380038003800380038007C0FFFE0F217CA018> I<03F0000C1C001007
+002007804003C04003C08003E0F003E0F801E0F801E0F801E02003E00003E00003C00003
+C0000780000700000E00001C0000180000300000600000C0000180000100000200200400
+200800201800603000403FFFC07FFFC0FFFFC013217EA018> I<03F8000C1E00100F0020
+07804007C07807C07803C07807C03807C0000780000780000700000F00000C0000380003
+F000001C00000F000007800007800003C00003C00003E02003E07003E0F803E0F803E0F0
+03C04003C0400780200780100F000C1C0003F00013227EA018> I<000300000300000700
+000700000F00001700001700002700006700004700008700018700010700020700060700
+040700080700080700100700200700200700400700C00700FFFFF8000700000700000700
+000700000700000700000700000F80007FF015217FA018> I<70F8F8F870000000000000
+000000000070F8F8F87005157C940E> 58 D<FFFFFFFEFFFFFFFE000000000000000000
+0000000000000000000000000000000000000000000000FFFFFFFEFFFFFFFE1F0C7D9126
+> 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0
+00800080018001000100010001000100010000000000000000000000038007C007C007C0
+038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000
+05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000
+203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001
+000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E
+0001F8FF800FFF20237EA225> 65 D<FFFFF8000F800E0007800780078003C0078003E0
+078001E0078001F0078001F0078001F0078001F0078001F0078001E0078003E0078007C0
+07800F8007803E0007FFFE0007800780078003C0078001E0078001F0078000F0078000F8
+078000F8078000F8078000F8078000F8078000F8078001F0078001F0078003E0078007C0
+0F800F00FFFFFC001D227EA123> I<0007E0100038183000E0063001C00170038000F007
+0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8
+000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078
+0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001
+C0010000E0020000381C000007E0001C247DA223> I<FFFFF0000F801E00078007000780
+0380078001C0078000E0078000F007800078078000780780007C0780003C0780003C0780
+003C0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780
+003E0780003C0780003C0780007C0780007807800078078000F0078000E0078001E00780
+03C0078007000F801E00FFFFF0001F227EA125> I<FFFFFFC00F8007C0078001C0078000
+C00780004007800040078000600780002007800020078000200780202007802000078020
+0007802000078060000780E00007FFE0000780E000078060000780200007802000078020
+000780200007800000078000000780000007800000078000000780000007800000078000
+00078000000FC00000FFFE00001B227EA120> 70 D<0007F008003C0C1800E0021801C0
+01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800
+000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
+1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700
+0078038000B801C000B800E00318003C0C080007F00020247DA226> I<FFFC3FFF0FC003
+F0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
+E0078001E0078001E0078001E0078001E0078001E007FFFFE0078001E0078001E0078001
+E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
+E0078001E0078001E0078001E00FC003F0FFFC3FFF20227EA125> I<FFFC0FC007800780
+078007800780078007800780078007800780078007800780078007800780078007800780
+07800780078007800780078007800780078007800FC0FFFC0E227EA112> I<FFFC00FF80
+0FC0007C0007800030000780002000078000400007800080000780010000078002000007
+80040000078008000007801000000780200000078040000007808000000781C000000783
+E000000785E000000788F000000790F0000007A078000007C03C000007803C000007801E
+000007800F000007800F00000780078000078007C000078003C000078001E000078001E0
+00078000F000078000F8000FC000FC00FFFC07FF8021227EA126> 75
+D<FFFC001F80000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00
+000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00010F00
+010F00010F00010F00030F00030F00020F00060F00060F001E1F007EFFFFFE18227DA11E
+> I<FF8007FF07C000F807C0007005E0002004F0002004F0002004780020047C0020043C
+0020041E0020041F0020040F002004078020040780200403C0200401E0200401E0200400
+F0200400F8200400782004003C2004003E2004001E2004000F2004000F20040007A00400
+03E0040003E0040001E0040001E0040000E00E0000601F000060FFE0002020227EA125>
+78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C
+0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8
+00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C
+0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000
+0FE0001F247DA226> I<FFFFF0000F803C0007800F0007800780078007C0078003C00780
+03E0078003E0078003E0078003E0078003E0078003E0078003C0078007C0078007800780
+0F0007803C0007FFF0000780000007800000078000000780000007800000078000000780
+0000078000000780000007800000078000000780000007800000078000000FC00000FFFC
+00001B227EA121> I<FFFFE000000F803C000007800E00000780078000078007C0000780
+03C000078003E000078003E000078003E000078003E000078003E000078003C000078007
+C000078007800007800E000007803C000007FFE000000780700000078038000007801C00
+0007801E000007800E000007800F000007800F000007800F000007800F000007800F8000
+07800F800007800F800007800F808007800FC080078007C0800FC003C100FFFC01E20000
+00007C0021237EA124> 82 D<03F0200C0C601802603001E07000E0600060E00060E000
+60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F
+C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000
+C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008
+4007800840078008C007800C800780048007800480078004800780040007800000078000
+000780000007800000078000000780000007800000078000000780000007800000078000
+000780000007800000078000000780000007800000078000000780000007800000078000
+00078000000FC00001FFFE001E227EA123> I<FFF0007FC01F80001F000F00000C000F80
+000C000780000800078000080003C000100003C000100003C000100001E000200001E000
+200001F000600000F000400000F000400000780080000078008000007C008000003C0100
+00003C010000001E020000001E020000001E020000000F040000000F040000000F8C0000
+000788000000078800000003D000000003D000000003F000000001E000000001E0000000
+00C000000000C000000000C0000022237FA125> 86 D<FFF03FFC03FE1F8007E000F80F
+0003C000700F0003C000200F0001E00020078001E00040078001E00040078003F0004003
+C002F0008003C002F0008003C002F0008003E00478018001E00478010001E00478010001
+E0083C010000F0083C020000F0083C020000F0101E02000078101E04000078101E040000
+78200F0400003C200F0800003C200F0800003C600F8800001E40079000001E4007900000
+1E4007D000001F8003F000000F8003E000000F8003E000000F0001E00000070001C00000
+070001C00000060000C0000002000080002F237FA132> I<FEFEC0C0C0C0C0C0C0C0C0C0
+C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0FE
+FE07317BA40E> 91 D<FEFE060606060606060606060606060606060606060606060606
+060606060606060606060606060606060606060606FEFE07317FA40E> 93
+D<1FE000303800780C00780E0030070000070000070000070000FF0007C7001E07003C07
+00780700700700F00708F00708F00708F00F087817083C23900FC1E015157E9418> 97
+D<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
+000E00000E00000E1F000E61C00E80600F00300E00380E003C0E001C0E001E0E001E0E00
+1E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00700C80600C41C0083F001723
+7FA21B> I<01FE000703000C07801C0780380300780000700000F00000F00000F00000F0
+0000F00000F00000F000007000007800403800401C00800C010007060001F80012157E94
+16> I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0
+F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE
+17237EA21B> I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F000
+00F00000F00000F00000F000007000007800203800201C00400E008007030000FC001315
+7F9416> I<003E0000E30001C78003878003078007000007000007000007000007000007
+0000070000070000070000FFF80007000007000007000007000007000007000007000007
+00000700000700000700000700000700000700000700000700000700000700000780007F
+F000112380A20F> I<00007003F1980E1E181C0E18380700380700780780780780780780
+7807803807003807001C0E001E1C0033F0002000002000003000003800003FFE001FFFC0
+0FFFE03000F0600030C00018C00018C00018C000186000306000303800E00E038003FE00
+15217F9518> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00
+000E00000E00000E00000E00000E1F800E60C00E80E00F00700F00700E00700E00700E00
+700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00
+70FFE7FF18237FA21B> I<1C003E003E003E001C00000000000000000000000000000000
+000E007E001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
+000E000E00FFC00A227FA10E> I<00E001F001F001F000E0000000000000000000000000
+00000000007007F000F00070007000700070007000700070007000700070007000700070
+00700070007000700070007000700070007000706070F0E0F0C061803F000C2C83A10F>
+I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
+000E00000E00000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8
+000F1C000E1E000E0E000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE1723
+7FA21A> I<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E
+000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
+00FFE00B237FA20E> I<0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E
+003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E00
+3800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038
+00E0FFE3FF8FFE27157F942A> I<0E1F80FE60C01E80E00F00700F00700E00700E00700E
+00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E
+0070FFE7FF18157F941B> I<01FC000707000C01801800C03800E0700070700070F00078
+F00078F00078F00078F00078F00078F000787000707800F03800E01C01C00E0380070700
+01FC0015157F9418> I<0E1F00FE61C00E80600F00700E00380E003C0E003C0E001E0E00
+1E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C00E3F
+000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B
+> I<01F8200704600E02601C01603801E07800E07800E0F000E0F000E0F000E0F000E0F0
+00E0F000E0F000E07800E07800E03801E01C01E00C02E0070CE001F0E00000E00000E000
+00E00000E00000E00000E00000E00000E00000E0000FFE171F7E941A> I<0E3CFE461E8F
+0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E000F00FFF0
+10157F9413> I<0F8830786018C018C008C008E008F0007F003FE00FF001F8003C801C80
+0C800CC00CC008E018D0308FC00E157E9413> I<02000200020002000600060006000E00
+1E003E00FFFC0E000E000E000E000E000E000E000E000E000E000E000E040E040E040E04
+0E040E040708030801F00E1F7F9E13> I<0E0070FE07F01E00F00E00700E00700E00700E
+00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006
+017003827800FC7F18157F941B> I<FF80FE1E00781E00300E00200E0020070040070040
+0780C003808003808001C10001C10000E20000E20000E200007400007400003800003800
+00380000100017157F941A> I<FF8FF87F3E01E03C1C01C0181C01E0180E01E0100E0260
+100E027010070270200704302007043820038438400388184003881C4001C81C8001D00C
+8001D00E8000F00F0000E0070000E00700006006000040020020157F9423> I<FF83FE1F
+00F00E00C007008007810003830001C20000E400007800007800003800003C00004E0000
+8F000187000103800201C00401E00C00E03E01F0FF03FE17157F941A> I<FF80FE1E0078
+1E00300E00200E00200700400700400780C003808003808001C10001C10000E20000E200
+00E200007400007400003800003800003800001000001000002000002000002000004000
+F04000F08000F180004300003C0000171F7F941A> I<3FFFC0380380300780200700600E
+00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00
+80380080780180700780FFFF8012157F9416> I<FFFFFFFFFFFF3001808C31> 124
+D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fl cmbx12 14.4 19
+/Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000
+FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007
+7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF
+00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80
+0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800
+003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8
+31> 67 D<FFFFFC0000FFFFFC0000FFFFFC000003FC00000003FC00000003FC00000003
+FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC
+00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00
+000003FC00000003FC00000003FC00000003FC0001C003FC0001C003FC0001C003FC0001
+C003FC0003C003FC00038003FC00038003FC00078003FC00078003FC000F8003FC000F80
+03FC001F8003FC007F8003FC01FF00FFFFFFFF00FFFFFFFF00FFFFFFFF0022297EA828>
+76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000
+03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000
+007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000
+003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000
+003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000
+007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800
+07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C
+A833> 79 D<FFFFF0007FFFFFFFF0007FFFFFFFF0007FFF03FE000001C001FE00000380
+01FE0000038001FF0000078000FF0000070000FF80000F00007F80000E00007FC0000E00
+003FC0001C00003FC0001C00003FE0003C00001FE0003800001FF0007800000FF0007000
+000FF80070000007F800E0000007F800E0000003FC01C0000003FC01C0000003FE03C000
+0001FE0380000001FF0780000000FF0700000000FF87000000007F8E000000007F8E0000
+00007FDE000000003FDC000000003FFC000000001FF8000000001FF8000000000FF00000
+00000FF0000000000FF00000000007E00000000007E00000000003C00000000003C00000
+30297FA833> 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F
+801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F
+803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F
+FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D<FFE00000FFE00000FFE000000FE000000FE0
+00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE0
+00000FE000000FE1FE000FEFFF800FFE07E00FF803F00FF001F80FE000FC0FE000FC0FE0
+007E0FE0007E0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0
+007F0FE0007E0FE0007E0FE0007E0FE000FC0FE000FC0FF001F80FF803F00F9C0FE00F0F
+FF800E01FC00202A7EA925> I<00007FF000007FF000007FF0000007F0000007F0000007
+F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007
+F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007
+F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007
+F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87
+FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00
+0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00
+0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0
+1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07
+F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007
+F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007
+F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018
+2A7EA915> I<FFE00000FFE00000FFE000000FE000000FE000000FE000000FE000000FE0
+00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE07E000FE1
+FF800FE30FC00FE40FE00FE807E00FF807F00FF007F00FF007F00FE007F00FE007F00FE0
+07F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE0
+07F00FE007F00FE007F00FE007F00FE007F0FFFE3FFFFFFE3FFFFFFE3FFF202A7DA925>
+104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF
+E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F
+E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I<FFE0FFE0FFE00FE00FE00FE0
+0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0
+0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE
+0F2A7EA912> 108 D<FFC07E00FFC1FF80FFC30FC00FC40FE00FC807E00FD807F00FD007
+F00FD007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007
+F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F0FFFE3F
+FFFFFE3FFFFFFE3FFF201B7D9A25> 110 D<003FE00001FFFC0003F07E000FC01F801F80
+0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00
+03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80
+0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I<FFE1FE00FFEFFF80FFFE0F
+E00FF803F00FF001F80FE001FC0FE000FC0FE000FE0FE000FE0FE0007F0FE0007F0FE000
+7F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007E0FE000FE0FE000FE0FE000
+FC0FE001FC0FF001F80FF807F00FFC0FE00FEFFF800FE1FC000FE000000FE000000FE000
+000FE000000FE000000FE000000FE000000FE000000FE00000FFFE0000FFFE0000FFFE00
+0020277E9A25> I<FFC1F0FFC7FCFFC63E0FCC7F0FD87F0FD07F0FD07F0FF03E0FE0000F
+E0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000F
+E0000FE0000FE000FFFF00FFFF00FFFF00181B7F9A1B> 114 D<03FE300FFFF03E03F078
+00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800
+FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016
+1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000
+0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000
+0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070
+07F0E003F0C001FF80007F0014267FA51A> I<FFE07FF0FFE07FF0FFE07FF00FE007F00F
+E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00F
+E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE00FF00F
+E00FF007E017F003F067FF01FFC7FF007F87FF201B7D9A25> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fm cmr12 14.4 20
+/Fm 20 118 df<78FCFCFEFE7A02020202040404080810204007127B8510> 44
+D<00200000E00001E0000FE000FFE000F1E00001E00001E00001E00001E00001E00001E0
+0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
+0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
+0001E00003F000FFFFC0FFFFC012287BA71D> 49 D<01FC0007FF000C0FC01803E02001
+F06001F04000F84000F8F800FCFC00FCFC007CFC007CFC007C7800FC0000FC0000F80000
+F80001F00001F00003E00003C0000780000700000E00001C0000380000300000600000C0
+000180000300040200040400080800081000082000183FFFF87FFFF0FFFFF0FFFFF01628
+7DA71D> I<000FC0003FF000F01801C01803803C07007C0F007C0E00381E00003C00003C
+00003C0000780000780000780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC
+001EF8001EF8001FF8001FF8001FF8001F78001F78001F78001F78001F3C001E3C001E1C
+003C1E003C0E007807007003C1E001FFC0007E0018297EA71D> 54
+D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF8001EF800
+1EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E005F0700
+9F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00703E00
+E03C01C01803801C0F000FFE0003F80018297EA71D> 57 D<0000FF00100007FFE03000
+1FC07830003E000C7000F80006F001F00003F003E00001F007C00000F00F800000700F80
+0000701F000000303F000000303E000000303E000000107E000000107E000000107C0000
+0000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000000
+00FC00000000FC0000FFFF7C0000FFFF7E000003F07E000001F03E000001F03E000001F0
+3F000001F01F000001F00F800001F00F800001F007C00001F003E00001F001F00002F000
+F80002F0003E000C70001FC038300007FFE0100000FF8000282B7DA92E> 71
+D<01FFFE01FFFE0007E00003E00003E00003E00003E00003E00003E00003E00003E00003
+E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003
+E00003E00003E00003E00003E00003E00003E00003E03003E07803E0FC03E0FC03E0FC03
+C0F807C0400780200F00300E000C3C0003F000172A7DA81E> 74
+D<0001FF0000000F01E000003C0078000078003C0000E0000E0001E0000F0003C0000780
+07800003C00F800003E01F000001F01F000001F03E000000F83E000000F87E000000FC7E
+000000FC7C0000007C7C0000007CFC0000007EFC0000007EFC0000007EFC0000007EFC00
+00007EFC0000007EFC0000007EFC0000007EFC0000007E7C0000007C7E000000FC7E0000
+00FC7E000000FC3E000000F83F000001F81F000001F01F000001F00F800003E007800003
+C007C00007C003E0000F8000F0001E000078003C00003C007800000F01E0000001FF0000
+272B7DA92E> 79 D<03FC00000C070000100380003C01C0003E01E0003E00F0001C00F0
+000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C00F0
+007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E0C7F
+8007F01E001A1A7E991D> 97 D<0F000000FF000000FF0000001F0000000F0000000F00
+00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00
+00000F0000000F07E0000F1838000F600E000F8007000F8007800F0003C00F0003C00F00
+01E00F0001E00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F00
+01E00F0001E00F0003E00F0003C00F0003800F8007800E800F000E401C000C303800080F
+C0001C2A7EA921> I<007F0001C0E00700100E00781E00F83C00F83C00707C0020780000
+F80000F80000F80000F80000F80000F80000F80000F800007800007C00003C00083C0008
+1E00100E002007006001C180007E00151A7E991A> I<00FC000387800701C00E01E01C00
+E03C00F03C00F0780078780078F80078F80078FFFFF8F80000F80000F80000F80000F800
+007800007800003C00083C00081E00100E002007004001C180007E00151A7E991A> 101
+D<00000F0001FC3080070743800E03C3801E03C1003C01E0003C01E0007C01F0007C01F0
+007C01F0007C01F0007C01F0003C01E0003C01E0001E03C0000E0380001707000011FC00
+0030000000300000003000000030000000180000001FFF80000FFFF00007FFF80018007C
+0030001E0070000E0060000700E0000700E0000700E0000700E000070070000E0070000E
+0038001C001C0038000781E00000FF000019287E9A1D> 103 D<1E003F003F003F003F00
+1E000000000000000000000000000000000000000F00FF00FF001F000F000F000F000F00
+0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FFF0
+0C297EA811> 105 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001E
+F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C
+1C00380E00700700E003C3C0007E00181A7E991D> 111 D<003F010001E0830003804300
+0F0027001E0017001E001F003C000F007C000F007C000F0078000F00F8000F00F8000F00
+F8000F00F8000F00F8000F00F8000F00F8000F007C000F007C000F003C000F003E001F00
+1E001F000F002F0007804F0001C18F00007E0F0000000F0000000F0000000F0000000F00
+00000F0000000F0000000F0000000F0000000F0000000F000000FFF00000FFF01C267E99
+1F> 113 D<0F0F80FF11C0FF23E01F43E00F83E00F81C00F80000F00000F00000F00000F
+00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F
+00000F8000FFFC00FFFC00131A7E9917> I<07F0801C0D80300380600180E00180E00080
+E00080F00080F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C0
+8001C0C001C0C001C0E00180E00380F00300CC0E0083F800121A7E9917> I<0080000080
+000080000080000180000180000180000380000380000780000F80001FFF80FFFF800780
+000780000780000780000780000780000780000780000780000780000780000780000780
+0007804007804007804007804007804007804007804003C08001C08000E100003E001225
+7FA417> I<0F000F00FF00FF00FF00FF001F001F000F000F000F000F000F000F000F000F
+000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F
+000F000F000F000F000F000F000F001F000F001F0007002F0003804F8001C08FF0007F0F
+F01C1A7E9921> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fn cmr17 20.74 18
+/Fn 18 119 df<000001FF00008000001FFFE0018000007F007801800001F8000E038000
+03E000070780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F8
+0000003F8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC000
+000007800FC000000007801F8000000003801F8000000003803F8000000003803F000000
+0001803F0000000001807F0000000001807F0000000001807E0000000000007E00000000
+0000FE000000000000FE000000000000FE000000000000FE000000000000FE0000000000
+00FE000000000000FE000000000000FE000000000000FE000000000000FE000000000000
+FE0000000000007E0000000000007E0000000000007F0000000000007F0000000001803F
+0000000001803F0000000001803F8000000001801F8000000001801F8000000003000FC0
+00000003000FC0000000030007E0000000060007E0000000060003F0000000060001F000
+00000C0000F80000001800007C0000001800003E0000003000001F0000006000000FC000
+01C0000003E0000380000001F8000E000000007F007C000000001FFFF00000000001FF00
+0000313D7CBB39> 67 D<FFFFFC000000FFFFFC00000003FE0000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000006001F80000006001F80000006001
+F80000006001F80000006001F8000000E001F8000000C001F8000000C001F8000000C001
+F8000000C001F8000001C001F8000001C001F8000001C001F8000003C001F8000007C001
+F8000007C001F800000FC001F800003F8001F80000FF8003FC0007FF80FFFFFFFFFF80FF
+FFFFFFFF802B3B7CBA32> 76 D<000003FF00000000001E01E000000000F0003C000000
+03C0000F000000078000078000000F000003C000003E000001F000007C000000F80000F8
+0000007C0001F00000003E0001F00000003E0003E00000001F0007E00000001F8007C000
+00000F800FC00000000FC00F8000000007C01F8000000007E01F8000000007E03F000000
+0003F03F0000000003F03F0000000003F07F0000000003F87E0000000001F87E00000000
+01F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001
+FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FC
+FE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F0000000003F87F
+0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000000007E01F80
+00000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000001F8003E000
+00001F0001F00000003E0001F80000007E0000F80000007C00007C000000F800003E0000
+01F000000F000003C000000780000780000003E0001F00000000F8007C000000001E01E0
+0000000003FF000000363D7CBB3E> 79 D<003F80000001C0F0000003003C000004001E
+00000C000F000018000780001C0007C0003E0003C0003F0003E0003F0003E0003F0003E0
+001E0003E000000003E000000003E000000003E00000003FE000000FF3E000007E03E000
+01F803E00003E003E0000FC003E0001F8003E0003F0003E0003E0003E0007E0003E0007E
+0003E060FC0003E060FC0003E060FC0003E060FC0007E060FC0007E0607C000BE0607E00
+0BE0603E0011F0C01F0060F0C007C1807F8000FE003E0023257CA427> 97
+D<03E0000000FFE0000000FFE000000007E000000003E000000003E000000003E0000000
+03E000000003E000000003E000000003E000000003E000000003E000000003E000000003
+E000000003E000000003E000000003E000000003E000000003E000000003E000000003E0
+00000003E000000003E03FC00003E0E0780003E3001C0003E6000F0003E800078003F800
+03C003F00001E003E00001F003E00000F003E00000F803E00000F803E00000FC03E00000
+7C03E000007C03E000007E03E000007E03E000007E03E000007E03E000007E03E000007E
+03E000007E03E000007E03E000007E03E000007C03E000007C03E00000FC03E00000F803
+E00000F803E00001F003E00001E003F00003E003D80003C003C80007800384000E000383
+001C000381C0F00003003F8000273C7EBB2C> I<0007F800003C0E0000F0018001E000C0
+03C00060078000300F0000701F0000F81F0001F83E0001F83E0001F87E0000F07C000000
+7C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000
+FC0000007C0000007C0000007E0000003E0000003E00000C1F00000C1F0000180F800018
+0780003003C0006001E000C000F00180003C0E000007F8001E257DA423> I<0007F80000
+3C1E0000F0078001C003C003C001E0078000F00F0000F81F0000781E00007C3E00007C3E
+00007C7E00003E7C00003E7C00003EFC00003EFC00003EFFFFFFFEFC000000FC000000FC
+000000FC000000FC000000FC0000007C0000007C0000007E0000003E0000003E0000061F
+0000060F00000C0F80000C0780001803C0003000E00060007000C0001E07000003FC001F
+257EA423> 101 D<0000FC0000078300000E0380001C07C0003C0FC000780FC000F80FC0
+00F8078000F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F00000FFFFFC00FFFFFC00
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000003F800007FFFE0007FFFE0001A3C7FBB
+18> I<07000F801FC01FC01FC00F80070000000000000000000000000000000000000000
+0000000000000007C0FFC0FFC00FC007C007C007C007C007C007C007C007C007C007C007
+C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C007C00FE0FFFEFFFE0F397DB815> 105 D<0003800007C0000FE0000FE0000FE00007C0
+000380000000000000000000000000000000000000000000000000000000000000000000
+0000000000000007E000FFE000FFE0000FE00003E00003E00003E00003E00003E00003E0
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
+7803C0FC07C0FC0780FC0780FC0F00780E00381C000FE000134A82B818> I<07C0FFC0FF
+C00FC007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C00FE0FFFEFFFE0F3C7DBB15> 108 D<03E01FE0003FC000FFE0607C00C0F800FFE0801E
+01003C0007E3000F06001E0003E4000F88001F0003E4000F88001F0003E8000790000F00
+03E80007D0000F8003F00007E0000F8003F00007E0000F8003E00007C0000F8003E00007
+C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
+03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
+C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
+03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
+C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
+07F0000FE0001FC0FFFF81FFFF03FFFEFFFF81FFFF03FFFE3F257EA443> I<03E01FE000
+FFE0607C00FFE0801E0007E3000F0003E4000F8003E4000F8003E800078003E80007C003
+F00007C003F00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E0
+0007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E000
+07C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007
+C003E00007C003E00007C003E00007C003E00007C007F0000FE0FFFF81FFFFFFFF81FFFF
+28257EA42C> I<0007FC0000001C070000007001C00001E000F00003C00078000780003C
+000F00001E001F00001F001E00000F003E00000F803E00000F807C000007C07C000007C0
+7C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC
+000007E0FC000007E0FC000007E07C000007C07C000007C07E00000FC03E00000F803E00
+000F801E00000F001F00001F000F00001E000780003C0003C000780001E000F000007001
+C000001C0700000007FC000023257EA427> I<03E03E00FFE0C300FFE1078007E20FC003
+E40FC003E80FC003E8078003E8030003F0000003F0000003F0000003E0000003E0000003
+E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
+E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
+E0000003E0000003E0000007F00000FFFFC000FFFFC0001A257EA41E> 114
+D<00FF02000700C6000C002E0010001E0030001E0060000E0060000E00E0000600E00006
+00E0000600F0000600F8000600FC0000007F0000003FF000003FFF80000FFFE00007FFF0
+0001FFFC00003FFE000001FE0000003F00C0001F00C0000F80C0000780E0000380E00003
+80E0000380E0000380F0000300F0000300F8000700F8000600E4000C00E2001800C18070
+00807F800019257DA41F> I<003000000030000000300000003000000030000000300000
+0070000000700000007000000070000000F0000000F0000001F0000001F0000003F00000
+07F000001FFFFE00FFFFFE0001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0018001F0018001F0018001F0018001F00180
+01F0018001F0018001F0018001F0018000F0010000F8030000F8030000780200003C0400
+000E08000003F00019357FB41E> I<FFFE000FFFFFFE000FFF07F00007F803E00003E003
+E00001C001F00001C001F000018001F800018000F800030000F8000300007C000600007C
+000600007E000600003E000C00003E000C00003F001C00001F001800001F001800000F80
+3000000F803000000FC070000007C060000007C060000003E0C0000003E0C0000003F1C0
+000001F180000001F180000000FB00000000FB00000000FF000000007E000000007E0000
+00003C000000003C000000003C0000000018000028257FA42A> 118
+D E
+%EndDVIPSBitmapFont
+end
+%%EndProlog
+%%BeginSetup
+%%Feature: *Resolution 300dpi
+TeXDict begin
+%%PaperSize: a4
+
+userdict/PStoPSxform PStoPSmatrix matrix currentmatrix
+ matrix invertmatrix matrix concatmatrix
+ matrix invertmatrix put
+%%EndSetup
+%%Page: (0,1) 1
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 0.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+/showpage{}def/copypage{}def/erasepage{}def
+PStoPSxform concat
+1 0 bop Fn 281 370 a(Cleaner) p 570 370 a(seman) n(tics) p
+927 370 a(for) p 1047 370 a(Ob) t(jectiv) n(e) p 1404
+370 a(Lab) r(el) p Fm 717 518 a(Jacques) p 934 518 a(Garrigue) 719
+634 y(Octob) r(er) p 945 634 a(26,) p 1040 634 a(1999) p
+Fl 11 836 a(Credits) p Fk 11 929 a(This) p 122 929 a(prop) q(osal) p
+319 929 a(con) o(tains) p 510 929 a(ideas) p 632 929
+a(from) p 747 929 a(Damien) p 928 929 a(Doligez) p 1101
+929 a(and) p 1196 929 a(Pierre) p 1340 929 a(W) l(eis.) p
+Fl 11 1073 a(Lab) r(els) p 221 1073 a(and) p 351 1073
+a(optionals) p Fk 11 1165 a(Lab) q(els) p 165 1165 a(and) p
+259 1165 a(optional) p 449 1165 a(argumen) o(ts) p 687
+1165 a(had) p 781 1165 a(t) o(w) o(o) p 873 1165 a(problems) p
+1082 1165 a(in) p 1139 1165 a(Ob) s(jectiv) o(e) p 1360
+1165 a(Lab) q(el.) p Fj 83 1280 a(\017) p Fk 133 1280
+a(They) p 259 1280 a(w) o(ere) p 372 1280 a(not) p 459
+1280 a(fully) p 570 1280 a(coheren) o(t) p 767 1280 a(with) p
+878 1280 a(the) p 963 1280 a(original) p 1139 1280 a(call-b) o(y-v) m
+(alue) p 1423 1280 a(seman) o(tics) p 1644 1280 a(of) p
+1700 1280 a(the) p 1784 1280 a(lan-) 133 1340 y(guage.) p
+303 1340 a(In) p 368 1340 a(some) p 495 1340 a(\(subtle\)) p
+681 1340 a(cases,) p 823 1340 a(a) p 868 1340 a(side-e\013ect) p
+1099 1340 a(migh) o(t) p 1243 1340 a(get) p 1329 1340
+a(dela) o(y) o(ed) p 1508 1340 a(more) p 1635 1340 a(than) p
+1753 1340 a(in) p 1814 1340 a(an) 133 1400 y(un) o(t) o(yp) q(ed) p
+322 1400 a(seman) o(tics.) p Fj 83 1502 a(\017) p Fk
+133 1502 a(F) l(or) p 220 1502 a(optional) p 410 1502
+a(argumen) o(ts,) p 660 1502 a(no) p 728 1502 a(un) o(t) o(yp) q(ed) p
+918 1502 a(seman) o(tics) p 1139 1502 a(existed.) 84
+1616 y(This) p 195 1616 a(new) p 295 1616 a(prop) q(osal) p
+492 1616 a(corrects) p 674 1616 a(these) p 799 1616 a(t) o(w) o(o) p
+891 1616 a(\015a) o(ws.) p Fi 11 1746 a(Syn) n(tax) p
+Fk 11 1838 a(W) l(e) p 95 1838 a(k) o(eep) p 206 1838
+a(Ob) s(jectiv) o(e) p 426 1838 a(Lab) q(el's) p 594
+1838 a(syn) o(tax,) p 764 1838 a(except) p 917 1838 a(for) p
+991 1838 a(default) p 1155 1838 a(v) m(alues) p 1301
+1838 a(in) p 1357 1838 a(optional) p 1547 1838 a(argumen) o(ts.) p
+Fh 329 1944 a(typ) n(expr) p Fk 528 1944 a(::=) p Fg
+634 1944 a(:) p 656 1944 a(:) p 678 1944 a(:) p Fj 579
+2004 a(j) p Fh 634 2004 a(typ) n(expr) p Fj 806 2004
+a(!) p Fh 870 2004 a(typ) n(expr) p Fj 579 2064 a(j) p
+Fk 634 2064 a([?]) p Fi(lab) r(el) p Fk 801 2064 a(:) p
+Fh(typ) n(expr) p Fj 987 2064 a(!) p Fh 1050 2064 a(typ) n(expr) 391
+2124 y(expr) p Fk 528 2124 a(::=) p Fg 634 2124 a(:) p
+656 2124 a(:) p 678 2124 a(:) p Fj 579 2185 a(j) p Fh
+634 2185 a(expr) p 746 2185 a(lab) n(ele) n(d-expr) p
+Ff 991 2163 a(+) p Fj 579 2245 a(j) p Fe 634 2245 a(fun) p
+Fj 728 2245 a(f) p Fh(lab) n(ele) n(d-simple-p) n(attern) p
+Fj 1209 2245 a(g) p Ff 1234 2227 a(+) p Fk 1280 2245
+a([) p Fe(when) p Fh 1412 2245 a(expr) p Fk 1507 2245
+a(]) p Fj 1535 2245 a(!) p Fh 1599 2245 a(expr) p Fj
+579 2305 a(j) p Fe 634 2305 a(function) p Fh 856 2305
+a(lab) n(ele) n(d-p) n(attern) p Fk 1177 2305 a([) p
+Fe(when) p Fh 1309 2305 a(expr) p Fk 1404 2305 a(]) p
+Fj 1432 2305 a(!) p Fh 1496 2305 a(expr) p Fj 785 2365
+a(f) p Fe(|) p Fh 851 2365 a(lab) n(ele) n(d-p) n(attern) p
+Fk 1172 2365 a([) p Fe(when) p Fg 1305 2365 a(expr) p
+Fk 1403 2365 a(]) p Fj 1430 2365 a(!) p Fh 1494 2365
+a(expr) p Fj 1589 2365 a(g) p Fd 1614 2347 a(\003) p
+Fh 242 2425 a(lab) n(ele) n(d-expr) p Fk 528 2425 a(::=) p
+634 2425 a([?]) p Fh(expr) p Fj 579 2486 a(j) p Fk 634
+2486 a([?]) p Fi(lab) r(el) p Fk 801 2486 a(:) p Fh(expr) 182
+2546 y(lab) n(ele) n(d-p) n(attern) p Fk 528 2546 a(::=) p
+Fh 634 2546 a(p) n(attern) p Fj 579 2606 a(j) p Fi 634
+2606 a(lab) r(el) p Fk 751 2606 a(:) p Fh(p) n(attern) p
+Fj 579 2666 a(j) p Fk 634 2666 a(?[) p Fe(\() p Fh(expr) p
+Fe(\)) p Fk(]) p Fi(lab) r(el) p Fk 943 2666 a(:) p Fh
+956 2666 a(p) n(attern) p Fk 926 2937 a(1) p eop
+PStoPSsaved restore
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 421.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+PStoPSxform concat
+2 1 bop Fi 11 168 a(Dynamic) p 247 168 a(seman) n(tics) p
+Fj 11 261 a(;) p Fk 52 261 a(is) p 101 261 a(a) p 141
+261 a(notation) p 337 261 a(for) p 411 261 a(the) p 495
+261 a(empt) o(y) p 644 261 a(lab) q(el.) 86 366 y(\() p
+Fe(fun) p Fi 198 366 a(l) p Fc 214 373 a(i) p Fk 227
+366 a(:) p Fg(x) p Fj 282 366 a(!) p Fg 346 366 a(e) p
+Fk(\)) p Fi 404 366 a(l) p Fc 420 373 a(1) p Fk 442 366
+a(:) p Fg 455 366 a(e) p Ff 478 373 a(1) p Fg 506 366
+a(:) p 528 366 a(:) p 550 366 a(:) p Fi 571 366 a(l) p
+Fc 587 373 a(n) p Fk 612 366 a(:) p Fg 625 366 a(e) p
+Fb 648 373 a(n) p Fj 515 427 a(!) p Fk 579 427 a(\() p
+Fg(e) p Fk([) p Fg(e) p Fb 658 434 a(i) p Fg 671 427
+a(=x) p Fk(]) p Fi 752 427 a(l) p Fc 768 434 a(1) p Fk
+790 427 a(:) p Fg(e) p Ff 827 434 a(1) p Fg 855 427 a(:) p
+877 427 a(:) p 899 427 a(:) p Fi 920 427 a(l) p Fc 936
+434 a(i) p Fd(\000) p Fc(1) p Fk 997 427 a(:) p Fg 1010
+427 a(e) p Fb 1033 434 a(i) p Fd(\000) p Ff(1) p Fi 1108
+427 a(l) p Fc 1124 434 a(i) p Ff(+) p Fc(1) p Fk 1185
+427 a(:) p Fg(e) p Fb 1222 434 a(i) p Ff(+1) p Fg 1289
+427 a(:) p 1311 427 a(:) p 1333 427 a(:) p Fi 1354 427
+a(l) p Fc 1370 434 a(n) p Fk 1395 427 a(:) p Fg 1408
+427 a(e) p Fb 1431 434 a(n) p Fk 86 487 a(\() p Fe(fun) p
+Fk 198 487 a(?) p Fi(l) p Fc 237 494 a(i) p Fk 250 487
+a(:) p Fg(x) p Fj 305 487 a(!) p Fg 369 487 a(e) p Fk(\)) p
+Fi 427 487 a(l) p Fc 443 494 a(1) p Fk 465 487 a(:) p
+Fg 478 487 a(e) p Ff 501 494 a(1) p Fg 529 487 a(:) p
+551 487 a(:) p 573 487 a(:) p Fi 594 487 a(l) p Fc 610
+494 a(n) p Fk 635 487 a(:) p Fg 648 487 a(e) p Fb 671
+494 a(n) p Fj 515 547 a(!) p Fg 579 547 a(e) p Fk([) p
+Fe(Some) p Fk 717 547 a(\() p Fg(e) p Fb 759 554 a(i) p
+Fk 773 547 a(\)) p Fg(=x) p Fk(]) p Fi 874 547 a(l) p
+Fc 890 554 a(1) p Fk 912 547 a(:) p Fg 925 547 a(e) p
+Ff 948 554 a(1) p Fg 976 547 a(:) p 998 547 a(:) p 1020
+547 a(:) p Fi 1042 547 a(l) p Fc 1058 554 a(i) p Fd(\000) p
+Fc(1) p Fk 1118 547 a(:) p Fg(e) p Fb 1155 554 a(i) p
+Fd(\000) p Ff(1) p Fi 1230 547 a(l) p Fc 1246 554 a(i) p
+Ff(+) p Fc(1) p Fk 1307 547 a(:) p Fg 1320 547 a(e) p
+Fb 1343 554 a(i) p Ff(+1) p Fg 1410 547 a(:) p 1432 547
+a(:) p 1454 547 a(:) p Fi 1476 547 a(l) p Fc 1492 554
+a(n) p Fk 1516 547 a(:) p Fg(e) p Fb 1553 554 a(n) p
+Fk 86 607 a(\() p Fe(fun) p Fk 198 607 a(?) p Fi(l) p
+Fk(:) p Fg 250 607 a(x) p Fj 292 607 a(!) p Fg 356 607
+a(e) p Fk(\)) p Fi 413 607 a(l) p Fc 429 614 a(1) p Fk
+451 607 a(:) p Fg(e) p Ff 488 614 a(1) p Fg 516 607 a(:) p
+538 607 a(:) p 560 607 a(:) p Fi 581 607 a(l) p Fc 597
+614 a(n) p Fk 621 607 a(:) p Fg(e) p Fb 658 614 a(n) p
+Fk 1154 607 a(when) p Fi 1281 607 a(l) p Fc 1297 614
+a(i) p Fk 1324 607 a(=) p Fj 1376 607 a(;) p Fk 1417
+607 a(and) p Fg 1512 607 a(l) p Fj 1541 607 a(62) p 1588
+607 a(f) p Fi(l) p Fc 1629 614 a(1) p Fg 1660 607 a(:) p
+1682 607 a(:) p 1704 607 a(:) p Fi 1725 607 a(l) p Fc
+1741 614 a(n) p Fj 1765 607 a(g) 515 667 y(!) p Fg 579
+667 a(e) p Fk([) p Fe(None) p Fg 717 667 a(=x) p Fk(]) p
+Fi 799 667 a(l) p Fc 815 674 a(1) p Fk 837 667 a(:) p
+Fg(e) p Ff 874 674 a(1) p Fg 901 667 a(:) p 923 667 a(:) p
+945 667 a(:) p Fi 967 667 a(l) p Fc 983 674 a(n) p Fk
+1007 667 a(:) p Fg(e) p Fb 1044 674 a(n) p Fk 86 728
+a(\(\() p Fe(fun) p Fi 217 728 a(l) p Fk(:) p Fg 246
+728 a(x) p Fj 288 728 a(!) p Fg 352 728 a(e) p Fk(\)) p
+Fi 409 728 a(l) p Fc 425 735 a(1) p Fk 447 728 a(:) p
+Fg(e) p Ff 484 735 a(1) p Fg 511 728 a(:) p 533 728 a(:) p
+555 728 a(:) p Fi 577 728 a(l) p Fc 593 735 a(m) p Fk
+629 728 a(:) p Fg 642 728 a(e) p Fb 665 735 a(m) p Fk
+698 728 a(\)) p Fi 733 728 a(l) p Fc 749 735 a(m) p Ff(+) p
+Fc(1) p Fk 833 728 a(:) p Fg 846 728 a(e) p Fb 869 735
+a(m) p Ff(+1) p Fg 955 728 a(:) p 977 728 a(:) p 999
+728 a(:) p Fi 1021 728 a(l) p Fc 1037 735 a(n) p Fk 1061
+728 a(:) p Fg(e) p Fb 1098 735 a(n) p Fk 1373 728 a(when) p
+Fi 1501 728 a(l) p Fj 1530 728 a(62) p 1577 728 a(f) p
+Fi(l) p Fc 1618 735 a(1) p Fg 1648 728 a(:) p 1670 728
+a(:) p 1692 728 a(:) p Fi 1714 728 a(l) p Fc 1730 735
+a(m) p Fj 1765 728 a(g) 515 788 y(!) p Fk 579 788 a(\() p
+Fe(fun) p Fi 691 788 a(l) p Fk(:) p Fg 720 788 a(x) p
+Fj 761 788 a(!) p Fg 825 788 a(e) p Fk(\)) p Fi 883 788
+a(l) p Fc 899 795 a(1) p Fk 921 788 a(:) p Fg 934 788
+a(e) p Ff 957 795 a(1) p Fg 985 788 a(:) p 1007 788 a(:) p
+1029 788 a(:) p Fi 1051 788 a(l) p Fc 1067 795 a(n) p
+Fk 1091 788 a(:) p Fg 1104 788 a(e) p Fb 1127 795 a(n) p
+Fk 86 848 a(\(\() p Fe(fun) p Fk 217 848 a(?) p Fi(l) p
+Fk(:) p Fg 269 848 a(x) p Fj 311 848 a(!) p Fg 375 848
+a(e) p Fk(\)) p Fi 432 848 a(l) p Fc 448 855 a(1) p Fk
+470 848 a(:) p Fg(e) p Ff 507 855 a(1) p Fg 535 848 a(:) p
+557 848 a(:) p 579 848 a(:) p Fi 600 848 a(l) p Fc 616
+855 a(m) p Fk 652 848 a(:) p Fg 665 848 a(e) p Fb 688
+855 a(m) p Fk 721 848 a(\)) p Fi 756 848 a(l) p Fc 772
+855 a(m) p Ff(+) p Fc(1) p Fk 856 848 a(:) p Fg 869 848
+a(e) p Fb 892 855 a(m) p Ff(+1) p Fg 978 848 a(:) p 1000
+848 a(:) p 1022 848 a(:) p Fi 1044 848 a(l) p Fc 1060
+855 a(n) p Fk 1084 848 a(:) p Fg(e) p Fb 1121 855 a(n) p
+Fk 1261 848 a(when) p Fj 1388 848 a(f) p Fi(l) p Fg(;) p
+Fj 1451 848 a(;g) p 1530 848 a(6) m(\\) p 1577 848 a(f) p
+Fi(l) p Fc 1618 855 a(1) p Fg 1648 848 a(:) p 1670 848
+a(:) p 1692 848 a(:) p Fi 1714 848 a(l) p Fc 1730 855
+a(m) p Fj 1765 848 a(g) 515 908 y(!) p Fk 579 908 a(\() p
+Fe(fun) p Fk 691 908 a(?) p Fi(l) p Fk(:) p Fg 743 908
+a(x) p Fj 785 908 a(!) p Fg 848 908 a(e) p Fk(\)) p Fi
+906 908 a(l) p Fc 922 915 a(1) p Fk 944 908 a(:) p Fg(e) p
+Ff 981 915 a(1) p Fg 1008 908 a(:) p 1030 908 a(:) p
+1052 908 a(:) p Fi 1074 908 a(l) p Fc 1090 915 a(n) p
+Fk 1114 908 a(:) p Fg 1127 908 a(e) p Fb 1150 915 a(n) p
+Fi 11 1035 a(T) n(yping) p Fk 11 1127 a(Seman) o(tics) p
+240 1127 a(are) p 321 1127 a(k) o(ept) p 430 1127 a(throughout) p
+685 1127 a(compilation) p 950 1127 a(b) o(y) p 1018 1127
+a(disallo) o(wing) p 1269 1127 a(lab) q(el) p 1387 1127
+a(comm) o(utation) p 1684 1127 a(for) p 1759 1127 a(func-) 11
+1187 y(tion) p 116 1187 a(t) o(yp) q(es.) p 278 1187
+a(Ho) o(w) o(ev) o(er,) p 494 1187 a(the) p 583 1187
+a(original) p 764 1187 a(comfort) p 949 1187 a(of) p
+1009 1187 a(out-of-order) p 1283 1187 a(application) p
+1540 1187 a(is) p 1594 1187 a(reco) o(v) o(ered) p 1814
+1187 a(b) o(y) 11 1247 y(allo) o(wing) p 207 1247 a(argumen) o(t) p
+431 1247 a(reordering) p 670 1247 a(in) p 732 1247 a(application,) p
+1005 1247 a(when) p 1138 1247 a(the) p 1227 1247 a(function's) p
+1457 1247 a(t) o(yp) q(e) p 1572 1247 a(is) p Fh 1626
+1247 a(wel) r(l) p 1731 1247 a(known) p Fk 11 1308 a(\() p
+Fh(c.f.) p Fk 118 1308 a(p) q(olymorphic) p 400 1308
+a(metho) q(ds\).) p Fl 11 1452 a(V) p 56 1452 a(arian) n(ts) p
+Fk 11 1544 a(V) l(arian) o(t) p 187 1544 a(t) o(yping,) p
+355 1544 a(as) p 417 1544 a(it) p 468 1544 a(is) p 519
+1544 a(presen) o(ted) p 739 1544 a(in) p 798 1544 a(the) p
+884 1544 a(user's) p 1022 1544 a(man) o(ual,) p 1210
+1544 a(is) p 1261 1544 a(not) p 1350 1544 a(principal:) p
+1576 1544 a(in) p 1635 1544 a(some) p 1760 1544 a(cases) 11
+1605 y(t) o(ypabilit) o(y) p 239 1605 a(of) p 301 1605
+a(an) p 375 1605 a(expression) p 616 1605 a(ma) o(y) p
+728 1605 a(dep) q(end) p 904 1605 a(on) p 978 1605 a(the) p
+1069 1605 a(order) p 1202 1605 a(in) p 1265 1605 a(whic) o(h) p
+1411 1605 a(the) p 1502 1605 a(t) o(yping) p 1660 1605
+a(algorithm) 11 1665 y(pro) q(ceeds.) p Fe 133 1779 a(#) p
+184 1779 a(let) p 286 1779 a(f1) p 363 1779 a(\(x) p
+440 1779 a(:) p 491 1779 a([<) p 568 1779 a(a) p 620
+1779 a(b\(int\)]\)) p 850 1779 a(=) p 902 1779 a(\(\)) 184
+1839 y(let) p 286 1839 a(f2) p 363 1839 a(\(x) p 440
+1839 a(:) p 491 1839 a([<) p 568 1839 a(a]\)) p 671 1839
+a(=) p 722 1839 a(\(\)) 184 1899 y(let) p 286 1899 a(f3) p
+363 1899 a(\(x) p 440 1899 a(:) p 491 1899 a([<) p 568
+1899 a(a) p 620 1899 a(b\(bool\)]\)) p 876 1899 a(=) p
+927 1899 a(\(\);;) 133 1960 y(val) p 235 1960 a(f1) p
+312 1960 a(:) p 363 1960 a([<) p 440 1960 a(a) p 491
+1960 a(b\(int\)]) p 696 1960 a(->) p 773 1960 a(unit) p
+902 1960 a(=) p 953 1960 a(<fun>) 133 2020 y(val) p 235
+2020 a(f2) p 312 2020 a(:) p 363 2020 a([<) p 440 2020
+a(a]) p 517 2020 a(->) p 594 2020 a(unit) p 722 2020
+a(=) p 773 2020 a(<fun>) 133 2080 y(val) p 235 2080 a(f3) p
+312 2080 a(:) p 363 2080 a([<) p 440 2080 a(a) p 491
+2080 a(b\(bool\)]) p 722 2080 a(->) p 799 2080 a(unit) p
+927 2080 a(=) p 978 2080 a(<fun>) 133 2140 y(#) p 184
+2140 a(fun) p 286 2140 a(x) p 338 2140 a(->) p 414 2140
+a(f1) p 491 2140 a(x;) p 568 2140 a(f2) p 645 2140 a(x;) p
+722 2140 a(f3) p 799 2140 a(x;;) 133 2200 y(-) p 184
+2200 a(:) p 235 2200 a([<) p 312 2200 a(a]) p 389 2200
+a(->) p 466 2200 a(unit) p 594 2200 a(=) p 645 2200 a(<fun>) 133
+2260 y(#) p 184 2260 a(fun) p 286 2260 a(x) p 338 2260
+a(->) p 414 2260 a(f1) p 491 2260 a(x;) p 568 2260 a(f3) p
+645 2260 a(x;;) 133 2321 y(Character) o(s) p 414 2321
+a(18-19:) 133 2381 y(This) p 261 2381 a(expressio) o(n) p
+543 2381 a(has) p 645 2381 a(type) p 773 2381 a([<) p
+850 2381 a(a) p 902 2381 a(b\(int\)]) p 1107 2381 a(but) p
+1209 2381 a(is) p 1286 2381 a(here) p 1414 2381 a(used) p
+1542 2381 a(with) p 1670 2381 a(type) 184 2441 y([<) p
+261 2441 a(a) p 312 2441 a(b\(bool\)]) p Fk 84 2555 a(Here) p
+204 2555 a(the) p 292 2555 a(constrain) o(t) p 526 2555
+a(in) o(tro) q(duced) p 775 2555 a(b) o(y) p Fe 848 2555
+a(f2) p Fk 920 2555 a(hides) p 1049 2555 a(the) p 1138
+2555 a(constructor) p Fe 1401 2555 a(b) p Fk(,) p 1462
+2555 a(and) p 1562 2555 a(a) o(v) o(oids) p 1714 2555
+a(a) p 1760 2555 a(clash) 11 2615 y(b) q(et) o(w) o(een) p
+Fe 199 2615 a(int) p Fk 292 2615 a(and) p Fe 387 2615
+a(bool) p Fk(.) 84 2676 y(An) p 163 2676 a(easy) p 270
+2676 a(w) o(a) o(y) p 369 2676 a(to) p 428 2676 a(solv) o(e) p
+547 2676 a(this) p 642 2676 a(w) o(ould) p 784 2676 a(b) q(e) p
+850 2676 a(to) p 909 2676 a(restrict) p 1077 2676 a(hiding) p
+1226 2676 a(absen) o(t) p 1379 2676 a(lab) q(els) p 1515
+2676 a(to) p 1575 2676 a(generic) p 1739 2676 a(t) o(yp) q(es.) 11
+2736 y(This) p 124 2736 a(w) o(a) o(y) p 224 2736 a(the) p
+310 2736 a(second) p 469 2736 a(case) p 574 2736 a(w) o(ould) p
+718 2736 a(still) p 814 2736 a(fail,) p 913 2736 a(since) p
+Fe 1034 2736 a(x) p Fk 1077 2736 a(has) p 1166 2736 a(a) p
+1208 2736 a(monorphic) p 1451 2736 a(t) o(yp) q(e.) p
+1584 2736 a(This) p 1697 2736 a(solution) 11 2796 y(w) o(ould) p
+153 2796 a(b) q(e) p 219 2796 a(correct) p 382 2796 a(and) p
+477 2796 a(principal.) 926 2937 y(2) p eop
+PStoPSsaved restore
+%%Page: (2,3) 2
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 0.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+/showpage{}def/copypage{}def/erasepage{}def
+PStoPSxform concat
+3 2 bop Fk 84 168 a(Ho) o(w) o(ev) o(er,) p 293 168 a(one) p
+382 168 a(can) p 472 168 a(easily) p 606 168 a(see) p
+684 168 a(that) p 789 168 a(this) p 884 168 a(solution) p
+1068 168 a(is) p 1117 168 a(coun) o(ter-in) o(tuitiv) o(e.) p
+1504 168 a(F) l(or) p 1591 168 a(the) p 1675 168 a(user,) p
+Fe 1791 168 a(b) p Fk 1833 168 a(is) 11 229 y(already) p
+183 229 a(an) p 250 229 a(imp) q(ossible) p 488 229 a(constructor,) p
+759 229 a(and) p 854 229 a(ha) o(ving) p 1011 229 a(a) p
+1052 229 a(clash) p 1174 229 a(on) p 1242 229 a(it) p
+1291 229 a(is) p 1340 229 a(hard) p 1453 229 a(to) p
+1513 229 a(understand.) 84 289 y(Another) p 277 289 a(solution) p
+463 289 a(is) p 514 289 a(to) p 575 289 a(go) p 642 289
+a(the) p 728 289 a(opp) q(osite) p 924 289 a(w) o(a) o(y) l(.) p
+1044 289 a(T) l(o) p 1117 289 a(accept) p 1271 289 a(more) p
+1395 289 a(programs.) p 1634 289 a(This) p 1747 289 a(is) p
+1798 289 a(the) 11 349 y(w) o(a) o(y) p 109 349 a(w) o(e) p
+181 349 a(explore) p 351 349 a(here,) p 470 349 a(with) p
+581 349 a(an) p 649 349 a(unc) o(hanged) p 891 349 a(syn) o(tax.) p
+Fi 11 479 a(T) n(yping) p Fk 11 571 a(The) p 114 571
+a(idea) p 220 571 a(is) p 273 571 a(to) p 336 571 a(dela) o(y) p
+466 571 a(uni\014cation) p 711 571 a(on) p 782 571 a(constructor) p
+1043 571 a(un) o(til) p 1161 571 a(they) p 1274 571 a(are) p
+1359 571 a(explicitely) p 1595 571 a(kno) o(wn) p 1753
+571 a(to) p 1816 571 a(b) q(e) 11 631 y(presen) o(t.) p
+199 631 a(W) l(e) p 280 631 a(k) o(eep) p 390 631 a(the) p
+472 631 a(\() p Fg(T) t(;) p 546 631 a(U;) p 601 631
+a(L) p Fk(\)) p 666 631 a(represen) o(tation) p 983 631
+a(of) p 1036 631 a(v) m(arian) o(t) p 1200 631 a(t) o(yp) q(es,) p
+1341 631 a(but) p Fg 1428 631 a(T) p Fk 1478 631 a(is) p
+1525 631 a(no) p 1591 631 a(longer) p 1735 631 a(a) p
+1774 631 a(map) 11 692 y(from) p 126 692 a(constructors) p
+403 692 a(to) p 462 692 a(t) o(yp) q(es,) p 605 692 a(but) p
+694 692 a(from) p 809 692 a(constructors) p 1086 692
+a(to) p 1146 692 a(sets) p 1241 692 a(of) p 1297 692
+a(t) o(yp) q(es.) 84 752 y(When) p 230 752 a(w) o(e) p
+307 752 a(unify) p 436 752 a(t) o(w) o(o) p 532 752 a(v) m(arian) o(t) p
+702 752 a(t) o(yp) q(es,) p 850 752 a(the) p 938 752
+a(\014rst) p 1043 752 a(step) p 1150 752 a(is) p 1204
+752 a(just) p 1305 752 a(to) p 1369 752 a(tak) o(e) p
+1479 752 a(the) p 1567 752 a(union) p 1707 752 a(of) p
+1767 752 a(b) q(oth) 11 812 y(t) o(yping) p 162 812 a(en) o(vironmen) o
+(ts,) p 476 812 a(dropping) p 682 812 a(unnecessary) p
+952 812 a(t) o(yp) q(es.) 204 932 y(\() p Fg(T) p Ff
+252 939 a(1) p Fg 272 932 a(;) p 294 932 a(U) p Ff 327
+939 a(1) p Fg 346 932 a(;) p 368 932 a(L) p Ff 401 939
+a(1) p Fk 421 932 a(\)) p Fj 451 932 a(^) p Fk 495 932
+a(\() p Fg(T) p Ff 543 939 a(2) p Fg 563 932 a(;) p 585
+932 a(U) p Ff 618 939 a(2) p Fg 637 932 a(;) p 659 932
+a(L) p Ff 692 939 a(2) p Fk 712 932 a(\)) p 745 932 a(=) p
+797 932 a(\(\() p Fg(T) p Ff 864 939 a(1) p Fj 883 932
+a(j) p Fb 897 939 a(U) p Fa 921 944 a(1) p Fd 938 939
+a(\\) p Fb(U) p Fa 986 944 a(2) p Fk 1005 932 a(\)) p
+Fj 1035 932 a([) p Fk 1079 932 a(\() p Fg(T) p Ff 1127
+939 a(2) p Fj 1146 932 a(j) p Fb 1160 939 a(U) p Fa 1184
+944 a(1) p Fd 1201 939 a(\\) p Fb(U) p Fa 1249 944 a(2) p
+Fk 1268 932 a(\)) p Fg(;) p 1309 932 a(U) p Ff 1342 939
+a(1) p Fj 1373 932 a(\\) p Fg 1417 932 a(U) p Ff 1450
+939 a(2) p Fg 1470 932 a(;) p 1492 932 a(L) p Ff 1525
+939 a(1) p Fj 1556 932 a([) p Fg 1600 932 a(L) p Ff 1633
+939 a(2) p Fk 1653 932 a(\)) 84 1042 y(Here) p 203 1042
+a(the) p 291 1042 a(union) p 431 1042 a(of) p 490 1042
+a(t) o(w) o(o) p 587 1042 a(t) o(yping) p 742 1042 a(en) o(vironmen) o
+(ts) p 1046 1042 a(is) p 1099 1042 a(the) p 1187 1042
+a(p) q(oin) o(t) o(wise) p 1407 1042 a(union) p 1547
+1042 a(of) p 1606 1042 a(their) p 1727 1042 a(sets) p
+1826 1042 a(of) 11 1102 y(t) o(yp) q(es) p 140 1102 a(for) p
+214 1102 a(eac) o(h) p 324 1102 a(constructor.) 84 1162
+y(This) p 195 1162 a(\014rst) p 296 1162 a(step) p 399
+1162 a(nev) o(er) p 529 1162 a(fails.) 84 1222 y(In) p
+145 1222 a(a) p 186 1222 a(second) p 343 1222 a(step,) p
+460 1222 a(structural) p 685 1222 a(constrain) o(ts) p
+934 1222 a(are) p 1015 1222 a(enforced) p 1209 1222 a(on) p
+1277 1222 a(the) p 1361 1222 a(resulting) p 1562 1222
+a(t) o(yp) q(e) p 1672 1222 a(\() p Fg(T) t(;) p 1746
+1222 a(U;) p 1801 1222 a(L) p Fk(\).) 11 1282 y(First,) p
+Fg 144 1282 a(L) p Fk 195 1282 a(should) p 351 1282 a(b) q(e) p
+418 1282 a(included) p 614 1282 a(in) p Fg 672 1282 a(U) p
+Fk 710 1282 a(.) p 749 1282 a(Then,) p 892 1282 a(for) p
+967 1282 a(all) p 1036 1282 a(constructors) p 1314 1282
+a(app) q(earing) p 1542 1282 a(in) p Fg 1600 1282 a(L) p
+Fk(,) p 1664 1282 a(the) p 1749 1282 a(set) p 1826 1282
+a(of) 11 1343 y(t) o(yp) q(es) p 136 1343 a(asso) q(ciated) p
+365 1343 a(with) p 472 1343 a(eac) o(h) p 578 1343 a(constructor) p
+833 1343 a(is) p 878 1343 a(collapsed) p 1084 1343 a(b) o(y) p
+1148 1343 a(uni\014cation.) p 1407 1343 a(This) p 1515
+1343 a(can) p 1600 1343 a(b) q(e) p 1663 1343 a(expressed) 11
+1403 y(b) o(y) p 78 1403 a(rewriting) p 287 1403 a(rules,) p
+417 1403 a(where) p Fg 558 1403 a(e) p Fk 597 1403 a(is) p
+646 1403 a(a) p 687 1403 a(m) o(ulti-equation) p 1015
+1403 a(and) p Fg 1109 1403 a(\036) p Fk 1155 1403 a(a) p
+1195 1403 a(set) p 1271 1403 a(of) p 1327 1403 a(m) o(ultiequations) 249
+1509 y(if) p Fg 294 1509 a(L) p Fj 341 1509 a(6\032) p
+Fg 393 1509 a(U) p Fk 448 1509 a(then) p 559 1509 a(\() p
+Fg(T) t(;) p 633 1509 a(U;) p 688 1509 a(L) p Fk(\)) p
+753 1509 a(=) p Fg 805 1509 a(e) p Fj 839 1509 a(^) p
+Fg 883 1509 a(\036) p Fj 926 1509 a(\000) p 956 1509
+a(!) p 1020 1509 a(?) p Fk 249 1629 a(if) p Fg 294 1629
+a(l) p Fj 323 1629 a(2) p Fg 370 1629 a(L) p Fk 420 1629
+a(and) p Fg 515 1629 a(T) p Fk 551 1629 a(\() p Fg(l) p
+Fk 586 1629 a(\)) p 617 1629 a(=) p Fj 669 1629 a(f) p
+Fg(\034) p Ff 715 1636 a(1) p Fg 735 1629 a(;) p 757
+1629 a(:) p 779 1629 a(:) p 801 1629 a(:) p 822 1629
+a(;) p 844 1629 a(\034) p Fb 865 1636 a(n) p Fj 889 1629
+a(g) p Fk 930 1629 a(then) 298 1689 y(\() p Fg(T) t(;) p
+372 1689 a(U;) p 427 1689 a(L) p Fk(\)) p 492 1689 a(=) p
+Fg 544 1689 a(e) p Fj 577 1689 a(^) p Fg 622 1689 a(\036) p
+Fj 664 1689 a(\000) p 695 1689 a(!) p Fk 759 1689 a(\() p
+Fg(T) p Fj 814 1689 a(f) p Fg(l) p Fj 867 1689 a(7!) p
+Fg 931 1689 a(\034) p Ff 952 1696 a(1) p Fj 972 1689
+a(g) p Fg(;) p 1019 1689 a(U;) p 1074 1689 a(L) p Fk(\)) p
+1139 1689 a(=) p Fg 1191 1689 a(e) p Fj 1225 1689 a(^) p
+Fg 1269 1689 a(\034) p Ff 1290 1696 a(1) p Fk 1324 1689
+a(=) p Fg 1376 1689 a(:) p 1398 1689 a(:) p 1420 1689
+a(:) p Fk 1447 1689 a(=) p Fg 1498 1689 a(\034) p Fb
+1519 1696 a(n) p Fj 1554 1689 a(^) p Fg 1598 1689 a(\036) p
+Fk 84 1796 a(Optionally) p 331 1796 a(one) p 425 1796
+a(can) p 519 1796 a(add) p 619 1796 a(rules) p 740 1796
+a(that) p 850 1796 a(remo) o(v) o(e) p 1022 1796 a(a) p
+1067 1796 a(constructor) p Fg 1329 1796 a(l) p Fk 1366
+1796 a(from) p Fg 1486 1796 a(U) p Fk 1545 1796 a(if) p
+1594 1796 a(the) p 1683 1796 a(equation) 11 1856 y(obtained) p
+211 1856 a(from) p Fg 326 1856 a(T) p Fk 362 1856 a(\() p
+Fg(l) p Fk 397 1856 a(\)) p 431 1856 a(has) p 518 1856
+a(no) p 586 1856 a(solution.) p 790 1856 a(Suc) o(h) p
+908 1856 a(rules) p 1024 1856 a(w) o(ould) p 1167 1856
+a(b) q(e) p 1233 1856 a(sound) p 1374 1856 a(and) p 1469
+1856 a(complete.) p Fi 11 1986 a(Syn) n(tax) p 198 1986
+a(of) p 262 1986 a(t) n(yp) r(es) p Fk 11 2078 a(Thanks) p
+188 2078 a(to) p 250 2078 a(the) p 336 2078 a(go) q(o) q(d) p
+458 2078 a(prop) q(erties) p 689 2078 a(of) p 747 2078
+a(these) p 874 2078 a(constrain) o(ts,) p 1139 2078 a(the) p
+1226 2078 a(surface) p 1392 2078 a(syn) o(tax) p 1551
+2078 a(of) p 1608 2078 a(t) o(yp) q(es) p 1740 2078 a(w) o(ould) 11
+2138 y(only) p 118 2138 a(ha) o(v) o(e) p 230 2138 a(to) p
+290 2138 a(b) q(e) p 356 2138 a(sligh) o(tly) p 527 2138
+a(extended.) p Fh 590 2244 a(tag-typ) n(e) p Fk 798 2244
+a(::=) p Fh 904 2244 a(ident) p Fj 849 2304 a(j) p Fh
+904 2304 a(ident) p Fe 1031 2304 a(\() p Fh(typ) n(expr-list) p
+Fe(\)) p Fh 523 2365 a(typ) n(expr-list) p Fk 798 2365
+a(::=) p Fh 904 2365 a(typ) n(expr) p Fj 849 2425 a(j) p
+Fh 904 2425 a(typ) n(expr) p Fe 1078 2425 a(&) p Fh 1120
+2425 a(typ) n(expr-list) p Fk 84 2531 a(Notice) p 234
+2531 a(that) p 336 2531 a(a) p 373 2531 a(0-ary) p 496
+2531 a(constructor) p 751 2531 a(and) p 842 2531 a(an) p
+907 2531 a(1-ary) p 1030 2531 a(construtor) p 1262 2531
+a(are) p 1340 2531 a(con) o(tradictory) l(,) p 1648 2531
+a(and) p 1740 2531 a(w) o(ould) 11 2592 y(result) p 146
+2592 a(in) p 203 2592 a(the) p 287 2592 a(absence) p
+466 2592 a(of) p 522 2592 a(this) p 617 2592 a(constructor.) 926
+2937 y(3) p eop
+PStoPSsaved restore
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 421.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+PStoPSxform concat
+4 3 bop Fi 11 168 a(Discussion) p Fk 11 261 a(Suc) o(h) p
+133 261 a(a) p 179 261 a(c) o(hange) p 345 261 a(has) p
+436 261 a(the) p 525 261 a(ma) s(jor) p 672 261 a(adv) m(an) o(tage) p
+907 261 a(of) p 967 261 a(b) q(oth) p 1087 261 a(reco) o(v) o(ering) p
+1324 261 a(principalit) o(y) p 1589 261 a(and) p 1688
+261 a(a) o(v) o(oiding) 11 321 y(unin) o(tuitiv) o(e) p
+266 321 a(error) p 392 321 a(messages.) p 640 321 a(Constrain) o(ts) p
+909 321 a(created) p 1087 321 a(in) p 1152 321 a(suc) o(h) p
+1269 321 a(a) p 1317 321 a(w) o(a) o(y) p 1423 321 a(are) p
+1512 321 a(v) o(ery) p 1626 321 a(ligh) o(t:) p 1772
+321 a(they) 11 381 y(alw) o(a) o(ys) p 165 381 a(app) q(ear) p
+325 381 a(inside) p 463 381 a(a) p 502 381 a(v) m(arian) o(t) p
+666 381 a(t) o(yp) q(e,) p 788 381 a(and) p 882 381 a(if) p
+926 381 a(the) p 1008 381 a(v) m(arian) o(t) p 1172 381
+a(t) o(yp) q(e) p 1281 381 a(do) q(es) p 1390 381 a(not) p
+1475 381 a(app) q(ear) p 1635 381 a(in) p 1691 381 a(the) p
+1774 381 a(\014nal) 11 441 y(t) o(yp) q(e) p 120 441
+a(sc) o(heme,) p 301 441 a(then) p 412 441 a(the) p 496
+441 a(constrain) o(t) p 725 441 a(can) p 815 441 a(b) q(e) p
+881 441 a(discarded) p 1098 441 a(safely) l(.) 84 501
+y(On) p 165 501 a(the) p 249 501 a(other) p 376 501 a(hand,) p
+512 501 a(there) p 637 501 a(are) p 718 501 a(t) o(w) o(o) p
+810 501 a(dra) o(wbac) o(ks.) p Fj 83 616 a(\017) p Fk
+133 616 a(Some) p 259 616 a(errors) p 393 616 a(will) p
+482 616 a(b) q(e) p 544 616 a(dela) o(y) o(ed) p 715
+616 a(longer) p 858 616 a(than) p 968 616 a(no) o(w,) p
+1080 616 a(un) o(til) p 1191 616 a(a) p 1228 616 a(construtor) p
+1460 616 a(is) p 1505 616 a(actually) p 1687 616 a(included) 133
+676 y(in) p Fg 189 676 a(L) p Fk(.) p 258 676 a(It) p
+311 676 a(is) p 360 676 a(not) p 446 676 a(clear) p 563
+676 a(ho) o(w) p 665 676 a(damageable) p 930 676 a(it) p
+979 676 a(is.) p Fj 83 777 a(\017) p Fk 133 777 a(While) p
+272 777 a(t) o(yp) q(e) p 378 777 a(inference) p 579
+777 a(is) p 625 777 a(simple) p 774 777 a(and) p 865
+777 a(costless) p 1036 777 a(for) p 1108 777 a(this) p
+1200 777 a(extension,) p 1426 777 a(simpli\014cation) p
+1724 777 a(of) p 1776 777 a(con-) 133 838 y(strain) o(ts) p
+310 838 a(|marking) p 551 838 a(constructors) p 830 838
+a(with) p 943 838 a(unsolv) m(able) p 1182 838 a(constrain) o(ts) p
+1432 838 a(as) p 1494 838 a(absen) o(t,) p 1663 838 a(and) p
+1760 838 a(elim-) 133 898 y(inating) p 300 898 a(redundan) o(t) p
+536 898 a(t) o(yp) q(es) p 667 898 a(in) p 726 898 a(constrain) o(ts|) p
+1025 898 a(is) p 1076 898 a(a) p 1119 898 a(bit) p 1197
+898 a(more) p 1320 898 a(exp) q(ensiv) o(e.) p 1565 898
+a(Also,) p 1691 898 a(allo) o(wing) 133 958 y(suc) o(h) p
+244 958 a(constrained) p 506 958 a(t) o(yp) q(es) p 637
+958 a(inside) p 777 958 a(signatures) p 1010 958 a(w) o(ould) p
+1154 958 a(mean) p 1286 958 a(ha) o(ving) p 1444 958
+a(to) p 1506 958 a(solv) o(e) p 1627 958 a(a) p 1669
+958 a(matc) o(hing) 133 1018 y(problem,) p 333 1018 a(whic) o(h) p
+469 1018 a(is) p 514 1018 a(exp) q(onen) o(tial) p 772
+1018 a(in) p 825 1018 a(the) p 906 1018 a(n) o(um) o(b) q(er) p
+1080 1018 a(of) p 1132 1018 a(connected) p 1356 1018
+a(constrain) o(ts) p 1600 1018 a(inside) p 1735 1018
+a(a) p 1772 1018 a(t) o(yp) q(e) 133 1078 y(sc) o(heme.) 84
+1193 y(Reasonably) p 340 1193 a(e\016cien) o(t) p 516
+1193 a(algorithms) p 754 1193 a(exist) p 866 1193 a(to) p
+922 1193 a(solv) o(e) p 1038 1193 a(these) p 1159 1193
+a(problems,) p 1379 1193 a(so) p 1435 1193 a(the) p 1515
+1193 a(di\016cult) o(y) p 1715 1193 a(is) p 1760 1193
+a(more) 11 1253 y(in) p 67 1253 a(the) p 151 1253 a(increased) p
+363 1253 a(complexit) o(y) p 611 1253 a(of) p 667 1253
+a(the) p 751 1253 a(t) o(yp) q(e-c) o(hec) o(k) o(er) p
+1031 1253 a(than) p 1145 1253 a(in) p 1202 1253 a(run-time) p
+1402 1253 a(cost.) p Fl 11 1397 a(Other) p 205 1397 a(features) p
+Fk 11 1490 a(Ob) s(jectiv) o(e) p 238 1490 a(Lab) q(el) p
+380 1490 a(con) o(tains) p 579 1490 a(t) o(w) o(o) p
+678 1490 a(other) p 812 1490 a(features:) p 1029 1490
+a(p) q(olymorphic) p 1318 1490 a(metho) q(ds) p 1521
+1490 a(and) p 1623 1490 a(t) o(yp) q(e-driv) o(en) 11
+1550 y(access) p 153 1550 a(of) p 208 1550 a(records.) p
+394 1550 a(Both) p 514 1550 a(of) p 568 1550 a(them) p
+692 1550 a(use) p 775 1550 a(the) p 857 1550 a(same) p
+978 1550 a(metho) q(d) p 1154 1550 a(of) p 1209 1550
+a(enforcing) p 1417 1550 a(principalit) o(y) p 1676 1550
+a(of) p 1730 1550 a(t) o(yping) 11 1610 y(through) p
+191 1610 a(tracing) p 351 1610 a(user) p 450 1610 a(pro) o(vided) p
+647 1610 a(t) o(yp) q(e) p 752 1610 a(information.) p
+1034 1610 a(With) p 1155 1610 a(this) p 1246 1610 a(tracing,) p
+1422 1610 a(their) p 1534 1610 a(implem) o(en) n(tation) 11
+1670 y(is) p 60 1670 a(v) o(ery) p 167 1670 a(easy) l(,) p
+283 1670 a(but) p 373 1670 a(without) p 554 1670 a(it) p
+603 1670 a(they) p 713 1670 a(lo) q(ose) p 834 1670 a(principalit) o(y)
+l(.) 84 1730 y(While) p 229 1730 a(these) p 357 1730
+a(features) p 543 1730 a(pro) o(vide) p 720 1730 a(some) p
+845 1730 a(comfort) p 1029 1730 a(in) p 1089 1730 a(writing) p
+1260 1730 a(user) p 1366 1730 a(programs,) p 1598 1730
+a(they) p 1711 1730 a(are) p 1795 1730 a(not) 11 1791
+y(strictly) p 182 1791 a(necessary) p 403 1791 a(for) p
+482 1791 a(the) p 571 1791 a(v) m(arious) p 742 1791
+a(libraries) p 934 1791 a(coming) p 1107 1791 a(with) p
+1223 1791 a(O'Labl) p 1391 1791 a(\(LablTk,) p 1602 1791
+a(LablGL) p 1787 1791 a(and) 11 1851 y(LablGTK\).) 926
+2937 y(4) p eop
+PStoPSsaved restore
+%%Trailer
+end
+userdict /end-hook known{end-hook}if
+%%EOF
diff --git a/testlabl/objvariant.ml b/testlabl/objvariant.ml
new file mode 100644
index 00000000..3233e03c
--- /dev/null
+++ b/testlabl/objvariant.ml
@@ -0,0 +1,42 @@
+(* use with [cvs update -r objvariants typing] *)
+
+let f (x : [> ]) = x#m 3;;
+let o = object method m x = x+2 end;;
+f (`A o);;
+let l = [`A o; `B(object method m x = x -2 method y = 3 end)];;
+List.map f l;;
+let g = function `A x -> x#m 3 | `B x -> x#y;;
+List.map g l;;
+fun x -> ignore (x=f); List.map x l;;
+fun (x : [< `A of _ | `B of _] -> int) -> ignore (x=f); List.map x l;;
+
+
+class cvar name =
+  object
+    method name = name
+    method print ppf = Format.pp_print_string ppf name
+  end
+
+type var = [`Var of cvar]
+
+class cint n =
+  object
+    method n = n
+    method print ppf = Format.pp_print_int ppf n
+  end
+
+class ['a] cadd (e1 : 'a) (e2 : 'a) =
+  object
+    constraint 'a = [> ]
+    method e1 = e1
+    method e2 = e2
+    method print ppf = Format.fprintf ppf "(%t, %t)" e1#print e2#print
+  end
+
+type 'a expr = [var | `Int of cint | `Add of 'a cadd]
+
+type expr1 = expr1 expr
+
+let print = Format.printf "%t@."
+
+let e1 : expr1 = `Add (new cadd (`Var (new cvar "x")) (`Int (new cint 2)))
diff --git a/testlabl/poly.exp b/testlabl/poly.exp
new file mode 100644
index 00000000..2b3faffa
--- /dev/null
+++ b/testlabl/poly.exp
@@ -0,0 +1,350 @@
+        Objective Caml version 3.07+19 (2004-05-26)
+
+#   * * *       #   type 'a t = { t : 'a; }
+# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
+# val f : 'a list -> 'a fold = <fun>
+# - : int = 6
+#               class ['a] ilist :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method add : 'a -> 'b
+    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  end
+#         class virtual ['a] vlist :
+  object ('b)
+    method virtual add : 'a -> 'b
+    method virtual fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  end
+#             class ilist2 :
+  int list ->
+  object ('a)
+    val l : int list
+    method add : int -> 'a
+    method fold : f:('b -> int -> 'b) -> init:'b -> 'b
+  end
+#             val ilist2 : 'a list -> 'a vlist = <fun>
+#             class ['a] ilist3 :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method add : 'a -> 'b
+    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  end
+#               class ['a] ilist4 :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method add : 'a -> 'b
+    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  end
+#                 class ['a] ilist5 :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method add : 'a -> 'b
+    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+  end
+#                 class ['a] ilist6 :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method add : 'a -> 'b
+    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+  end
+#       class virtual ['a] olist :
+  object method virtual fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+#         class ['a] onil :
+  object method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+#             class ['a] ocons :
+  hd:'a ->
+  tl:'a olist ->
+  object
+    val hd : 'a
+    val tl : 'a olist
+    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+  end
+#               class ['a] ostream :
+  hd:'a ->
+  tl:'a ostream ->
+  object
+    val hd : 'a
+    val tl : 'a ostream
+    method empty : bool
+    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+  end
+#                   class ['a] ostream1 :
+  hd:'a ->
+  tl:'b ->
+  object ('b)
+    val hd : 'a
+    val tl : 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+    method hd : 'a
+    method tl : 'b
+  end
+#           class vari : object method m : [< `A | `B | `C ] -> int end
+#       class vari : object method m : [< `A | `B | `C ] -> int end
+#           module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
+#         class varj : object method m : [< V.v ] -> int end
+#         module type T =
+  sig class vari : object method m : [< `A | `B | `C ] -> int end end
+#             module M0 :
+  sig class vari : object method m : [< `A | `B | `C ] -> int end end
+#   module M : T
+# val v : M.vari = <obj>
+# - : int = 1
+#               class point :
+  x:int ->
+  y:int -> object val x : int val y : int method x : int method y : int end
+#           class color_point :
+  x:int ->
+  y:int ->
+  color:string ->
+  object
+    val color : string
+    val x : int
+    val y : int
+    method color : string
+    method x : int
+    method y : int
+  end
+#                   class circle :
+  #point ->
+  r:int ->
+  object val p : point val r : int method distance : #point -> float end
+#           val p0 : point = <obj>
+val p1 : point = <obj>
+val cp : color_point = <obj>
+val c : circle = <obj>
+val d : float = 11.4536240470737098
+#   val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
+#   Characters 41-42:
+This expression has type < m : 'a. 'a -> 'a list > but is here used with type
+  < m : 'a. 'a -> 'b >
+The universal variable 'a would escape its scope
+#           class id : object method id : 'a -> 'a end
+#         class type id_spec = object method id : 'a -> 'a end
+#       class id_impl : object method id : 'a -> 'a end
+#               class a : object method m : bool end
+class b : object method id : 'a -> 'a end
+#           Characters 72-77:
+This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
+#         Characters 75-80:
+This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
+#           Characters 80-85:
+This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+#                 Characters 92-159:
+This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+#         class c : object method m : 'a -> 'b -> 'a end
+#     val f1 : id -> int * bool = <fun>
+#   val f2 : id -> int * bool = <fun>
+#   Characters 24-28:
+This expression has type bool but is here used with type int
+#   val f4 : id -> int * bool = <fun>
+#           class c : object method m : #id -> int * bool end
+#             class id2 : object method id : 'a -> 'a method mono : int -> int end
+#   val app : int * bool = (1, true)
+#   Characters 4-25:
+The type abbreviation foo is cyclic
+#     class ['a] bar : 'a -> object  end
+#   type 'a foo = 'a foo bar
+#   - : (< m : 'b. 'b * 'a > as 'a) -> 'c * 'a = <fun>
+# - : (< m : 'b. 'a * 'b list > as 'a) -> 'a * 'c list = <fun>
+# val f :
+  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
+  'a * (< n : 'c; .. > as 'c) = <fun>
+#   - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
+    (< m : 'c; n : 'a; .. > as 'c)
+= <fun>
+#   type sum = T of < id : 'a. 'a -> 'a >
+# - : sum -> 'a -> 'a = <fun>
+#   type record = { r : < id : 'a. 'a -> 'a >; }
+# - : record -> 'a -> 'a = <fun>
+# - : record -> 'a -> 'a = <fun>
+#       class myself : object ('a) method self : 'b -> 'a end
+#                       class number :
+  object ('a)
+    val num : int
+    method num : int
+    method prev : 'a
+    method succ : 'a
+    method switch : zero:(unit -> 'b) -> prev:('a -> 'b) -> 'b
+  end
+#     val id : 'a -> 'a = <fun>
+#       class c : object method id : 'a -> 'a end
+#         class c' : object method id : 'a -> 'a end
+#               class d :
+  object
+    val mutable count : int
+    method count : int
+    method id : 'a -> 'a
+    method old : 'b -> 'b
+  end
+#             class ['a] olist :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method cons : 'a -> 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+  end
+#   val sum : int #olist -> int = <fun>
+#   val count : 'a #olist -> int = <fun>
+#     val append : 'a #olist -> ('a #olist as 'b) -> 'b = <fun>
+#     type 'a t = unit
+#   class o : object method x : [> `A ] t -> unit end
+#   class c : object method m : d end
+class d : ?x:int -> unit -> object  end
+# class d : ?x:int -> unit -> object  end
+class c : object method m : d end
+#           class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
+class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
+class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
+#       class type node_type = object method as_variant : [> `Node of node_type ] end
+#       class node : node_type
+#     class node : object method as_variant : [> `Node of node_type ] end
+#   type bad = { bad : 'a. 'a option ref; }
+# Characters 17-25:
+This field value has type 'a option ref which is less general than
+  'b. 'b option ref
+# type bad2 = { mutable bad2 : 'a. 'a option ref option; }
+# val bad2 : bad2 = {bad2 = None}
+# Characters 13-28:
+This field value has type 'a option ref option which is less general than
+  'b. 'b option ref option
+#       type 'a t = [ `A of 'a ]
+#       class c : object method m : ([> 'a t ] as 'a) -> unit end
+#         class c : object method m : ([> 'a t ] as 'a) -> unit end
+#     class c : object method m : ([> 'a t ] as 'a) -> 'a end
+#     class c : object method m : ([> `A ] as 'a) option -> 'a end
+#           Characters 145-166:
+This type scheme cannot quantify 'a :
+it escapes this scope.
+#                 type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
+type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b >
+class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
+type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
+#     Characters 19-25:
+The type abbreviation t is cyclic
+#       class ['a] a : object constraint 'a = [> `A of 'a a ] end
+type t = [ `A of t a ]
+#     Characters 71-80:
+Constraints are not satisfied in this type.
+Type ('a, 'b) t should be an instance of ('c, 'c) t
+#     type 'a t = 'a
+type u = int t
+#     type 'a t constraint 'a = int
+# Characters 26-32:
+Constraints are not satisfied in this type.
+Type 'a u t should be an instance of int t
+# type 'a u = 'a constraint 'a = int
+type 'a v = 'a u t constraint 'a = int
+#     type g = int
+# type 'a t = unit constraint 'a = g
+# Characters 26-32:
+Constraints are not satisfied in this type.
+Type 'a u t should be an instance of g t
+# type 'a u = 'a constraint 'a = g
+type 'a v = 'a u t constraint 'a = int
+#     Characters 38-58:
+In the definition of v, type 'a list u should be 'a u
+#       type 'a t = 'a
+type 'a u = A of 'a t
+#     type 'a t = < a : 'a >
+# - : ('a t as 'a) -> 'a t = <fun>
+# type u = 'a t as 'a
+#       type t = A | B
+# - : [> `A ] * t -> int = <fun>
+# - : [> `A ] * t -> int = <fun>
+# - : [> `A ] option * t -> int = <fun>
+#   - : [> `A ] option * t -> int = <fun>
+# - : t * [< `A | `B ] -> int = <fun>
+# - : [< `A | `B ] * t -> int = <fun>
+# Characters 0-41:
+Warning: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(`AnyExtraTag, `AnyExtraTag)
+- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
+# Characters 0-29:
+Warning: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(_, 0)
+Characters 21-24:
+Warning: this match case is unused.
+- : [ `B ] * int -> int = <fun>
+# Characters 0-29:
+Warning: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(0, _)
+Characters 21-24:
+Warning: this match case is unused.
+- : int * [ `B ] -> int = <fun>
+#       Characters 69-135:
+Constraints are not satisfied in this type.
+Type
+([> `B of 'a ], 'a) b as 'a
+should be an instance of
+(('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
+#                             class type ['a, 'b] a =
+  object
+    constraint 'a = ('a, 'b) #a
+    constraint 'b = ('a, 'b) #b
+    method as_a : ('a, 'b) a
+    method b : 'b
+  end
+class type ['a, 'b] b =
+  object
+    constraint 'a = ('a, 'b) #a
+    constraint 'b = ('a, 'b) #b
+    method a : 'a
+    method as_b : ('a, 'b) b
+  end
+class type ['a] ca =
+  object ('b)
+    constraint 'a = ('b, 'a) #b
+    method as_a : ('b, 'a) a
+    method b : 'a
+  end
+class type ['a] cb =
+  object ('b)
+    constraint 'a = ('a, 'b) #a
+    method a : 'a
+    method as_b : ('a, 'b) b
+  end
+type bt = 'a ca cb as 'a
+#     class c : object method m : int end
+# val f : unit -> c = <fun>
+# val f : unit -> c = <fun>
+# Characters 11-60:
+Warning: the following private methods were made public implicitly:
+  n
+val f : unit -> < m : int; n : int > = <fun>
+# Characters 11-56:
+This object is expected to have type c but has actually type
+  < m : int; n : 'a >
+Only the second object type has a method n
+# Characters 11-69:
+This object is expected to have type < n : int > but has actually type
+  < m : 'a >
+Only the first object type has a method n
+#         Characters 66-124:
+This object is expected to have type < x : int; .. > but has actually type
+  < x : int >
+Self type cannot be unified with a closed object type
+#         val o : < x : int > = <obj>
+#         Characters 76-77:
+This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a
+but is here used with type
+  < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) >
+Types for method m are incompatible
+#         Characters 176-177:
+This expression has type foo' = < m : 'a. 'a * 'a foo >
+but is here used with type bar' = < m : 'a. 'a * 'a bar >
+Type 'a foo = < m : 'a * 'a foo > is not compatible with type
+  'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > 
+Type 'a foo = < m : 'a * 'a foo > is not compatible with type
+  < m : 'b. 'b * 'a bar > 
+Types for method m are incompatible
+# 
diff --git a/testlabl/poly.exp2 b/testlabl/poly.exp2
new file mode 100644
index 00000000..dba450e7
--- /dev/null
+++ b/testlabl/poly.exp2
@@ -0,0 +1,357 @@
+        Objective Caml version 3.07+19 (2004-05-26)
+
+#   * * *       #   type 'a t = { t : 'a; }
+# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
+# val f : 'a list -> 'a fold = <fun>
+# - : int = 6
+#               class ['a] ilist :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method add : 'a -> 'b
+    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  end
+#         class virtual ['a] vlist :
+  object ('b)
+    method virtual add : 'a -> 'b
+    method virtual fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  end
+#             class ilist2 :
+  int list ->
+  object ('a)
+    val l : int list
+    method add : int -> 'a
+    method fold : f:('b -> int -> 'b) -> init:'b -> 'b
+  end
+#             val ilist2 : 'a list -> 'a vlist = <fun>
+#             class ['a] ilist3 :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method add : 'a -> 'b
+    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  end
+#               class ['a] ilist4 :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method add : 'a -> 'b
+    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  end
+#                 class ['a] ilist5 :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method add : 'a -> 'b
+    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+  end
+#                 class ['a] ilist6 :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method add : 'a -> 'b
+    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+  end
+#       class virtual ['a] olist :
+  object method virtual fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+#         class ['a] onil :
+  object method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+#             class ['a] ocons :
+  hd:'a ->
+  tl:'a olist ->
+  object
+    val hd : 'a
+    val tl : 'a olist
+    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+  end
+#               class ['a] ostream :
+  hd:'a ->
+  tl:'a ostream ->
+  object
+    val hd : 'a
+    val tl : < empty : bool; fold : 'b. f:('a -> 'b -> 'b) -> init:'b -> 'b >
+    method empty : bool
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+  end
+#                   class ['a] ostream1 :
+  hd:'a ->
+  tl:'b ->
+  object ('b)
+    val hd : 'a
+    val tl : 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+    method hd : 'a
+    method tl : 'b
+  end
+#           class vari : object method m : [< `A | `B | `C ] -> int end
+#       class vari : object method m : [< `A | `B | `C ] -> int end
+#           module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
+#         class varj : object method m : [< V.v ] -> int end
+#         module type T =
+  sig class vari : object method m : [< `A | `B | `C ] -> int end end
+#             module M0 :
+  sig class vari : object method m : [< `A | `B | `C ] -> int end end
+#   module M : T
+# val v : M.vari = <obj>
+# - : int = 1
+#               class point :
+  x:int ->
+  y:int -> object val x : int val y : int method x : int method y : int end
+#           class color_point :
+  x:int ->
+  y:int ->
+  color:string ->
+  object
+    val color : string
+    val x : int
+    val y : int
+    method color : string
+    method x : int
+    method y : int
+  end
+#                   class circle :
+  #point ->
+  r:int ->
+  object val p : point val r : int method distance : #point -> float end
+#           val p0 : point = <obj>
+val p1 : point = <obj>
+val cp : color_point = <obj>
+val c : circle = <obj>
+val d : float = 11.4536240470737098
+#   val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
+#   Characters 41-42:
+This expression has type < m : 'a. 'a -> 'a list > but is here used with type
+  < m : 'a. 'a -> 'b >
+The universal variable 'a would escape its scope
+#           class id : object method id : 'a -> 'a end
+#         class type id_spec = object method id : 'a -> 'a end
+#       class id_impl : object method id : 'a -> 'a end
+#               class a : object method m : bool end
+class b : object method id : 'a -> 'a end
+#           Characters 72-77:
+This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
+#         Characters 75-80:
+This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
+#           Characters 80-85:
+This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+#                 Characters 92-159:
+This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+#         class c : object method m : 'a -> 'b -> 'a end
+#     val f1 : id -> int * bool = <fun>
+#   val f2 : id -> int * bool = <fun>
+#   Characters 24-28:
+This expression has type bool but is here used with type int
+#   Characters 27-31:
+Warning: This use of a polymorphic method is not principal
+Characters 35-39:
+Warning: This use of a polymorphic method is not principal
+val f4 : id -> int * bool = <fun>
+#           class c : object method m : #id -> int * bool end
+#             class id2 : object method id : 'a -> 'a method mono : int -> int end
+#   val app : int * bool = (1, true)
+#   Characters 4-25:
+The type abbreviation foo is cyclic
+#     class ['a] bar : 'a -> object  end
+#   type 'a foo = 'a foo bar
+#   - : (< m : 'b. 'b * 'a > as 'a) -> 'c * (< m : 'e. 'e * 'd > as 'd) = <fun>
+# - : (< m : 'b. 'a * 'b list > as 'a) ->
+    (< m : 'd. 'c * 'd list > as 'c) * 'e list
+= <fun>
+# val f :
+  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
+  (< m : 'd. 'c * (< n : 'd; .. > as 'd) > as 'c) * (< n : 'e; .. > as 'e) =
+  <fun>
+#   - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
+    (< m : 'c; n : < p : 'e. < m : 'e; n : 'd; .. > as 'e > as 'd; .. > as 'c)
+= <fun>
+#   type sum = T of < id : 'a. 'a -> 'a >
+# - : sum -> 'a -> 'a = <fun>
+#   type record = { r : < id : 'a. 'a -> 'a >; }
+# - : record -> 'a -> 'a = <fun>
+# - : record -> 'a -> 'a = <fun>
+#       class myself : object ('a) method self : 'b -> 'a end
+#                       class number :
+  object ('a)
+    val num : int
+    method num : int
+    method prev : 'a
+    method succ : 'a
+    method switch : zero:(unit -> 'b) -> prev:('a -> 'b) -> 'b
+  end
+#     val id : 'a -> 'a = <fun>
+#       class c : object method id : 'a -> 'a end
+#         class c' : object method id : 'a -> 'a end
+#               class d :
+  object
+    val mutable count : int
+    method count : int
+    method id : 'a -> 'a
+    method old : 'b -> 'b
+  end
+#             class ['a] olist :
+  'a list ->
+  object ('b)
+    val l : 'a list
+    method cons : 'a -> 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+  end
+#   val sum : int #olist -> int = <fun>
+#   val count : 'a #olist -> int = <fun>
+#     val append : 'a #olist -> ('a #olist as 'b) -> 'b = <fun>
+#     type 'a t = unit
+#   class o : object method x : [> `A ] t -> unit end
+#   class c : object method m : d end
+class d : ?x:int -> unit -> object  end
+# class d : ?x:int -> unit -> object  end
+class c : object method m : d end
+#           class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
+class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
+class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
+#       class type node_type = object method as_variant : [> `Node of node_type ] end
+#       class node : node_type
+#     class node : object method as_variant : [> `Node of node_type ] end
+#   type bad = { bad : 'a. 'a option ref; }
+# Characters 17-25:
+This field value has type 'a option ref which is less general than
+  'b. 'b option ref
+# type bad2 = { mutable bad2 : 'a. 'a option ref option; }
+# val bad2 : bad2 = {bad2 = None}
+# Characters 13-28:
+This field value has type 'a option ref option which is less general than
+  'b. 'b option ref option
+#       type 'a t = [ `A of 'a ]
+#       class c : object method m : ([> 'a t ] as 'a) -> unit end
+#         class c : object method m : ([> 'a t ] as 'a) -> unit end
+#     class c : object method m : ([> 'a t ] as 'a) -> 'a end
+#     class c : object method m : ([> `A ] as 'a) option -> 'a end
+#           Characters 145-166:
+This type scheme cannot quantify 'a :
+it escapes this scope.
+#                 type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
+type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b >
+class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
+type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
+#     Characters 19-25:
+The type abbreviation t is cyclic
+#       class ['a] a : object constraint 'a = [> `A of 'a a ] end
+type t = [ `A of t a ]
+#     Characters 71-80:
+Constraints are not satisfied in this type.
+Type ('a, 'b) t should be an instance of ('c, 'c) t
+#     type 'a t = 'a
+type u = int t
+#     type 'a t constraint 'a = int
+# Characters 26-32:
+Constraints are not satisfied in this type.
+Type 'a u t should be an instance of int t
+# type 'a u = 'a constraint 'a = int
+type 'a v = 'a u t constraint 'a = int
+#     type g = int
+# type 'a t = unit constraint 'a = g
+# Characters 26-32:
+Constraints are not satisfied in this type.
+Type 'a u t should be an instance of g t
+# type 'a u = 'a constraint 'a = g
+type 'a v = 'a u t constraint 'a = int
+#     Characters 38-58:
+In the definition of v, type 'a list u should be 'a u
+#       type 'a t = 'a
+type 'a u = A of 'a t
+#     type 'a t = < a : 'a >
+# - : ('a t as 'a) -> ('b t as 'b) t = <fun>
+# type u = 'a t as 'a
+#       type t = A | B
+# - : [> `A ] * t -> int = <fun>
+# - : [> `A ] * t -> int = <fun>
+# - : [> `A ] option * t -> int = <fun>
+#   - : [> `A ] option * t -> int = <fun>
+# - : t * [< `A | `B ] -> int = <fun>
+# - : [< `A | `B ] * t -> int = <fun>
+# Characters 0-41:
+Warning: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(`AnyExtraTag, `AnyExtraTag)
+- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
+# Characters 0-29:
+Warning: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(_, 0)
+Characters 21-24:
+Warning: this match case is unused.
+- : [ `B ] * int -> int = <fun>
+# Characters 0-29:
+Warning: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(0, _)
+Characters 21-24:
+Warning: this match case is unused.
+- : int * [ `B ] -> int = <fun>
+#       Characters 69-135:
+Constraints are not satisfied in this type.
+Type
+([> `B of 'a ], 'a) b as 'a
+should be an instance of
+(('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
+#                             class type ['a, 'b] a =
+  object
+    constraint 'a = ('a, 'b) #a
+    constraint 'b = ('a, 'b) #b
+    method as_a : ('a, 'b) a
+    method b : 'b
+  end
+class type ['a, 'b] b =
+  object
+    constraint 'a = ('a, 'b) #a
+    constraint 'b = ('a, 'b) #b
+    method a : 'a
+    method as_b : ('a, 'b) b
+  end
+class type ['a] ca =
+  object ('b)
+    constraint 'a = ('b, 'a) #b
+    method as_a : ('b, 'a) a
+    method b : 'a
+  end
+class type ['a] cb =
+  object ('b)
+    constraint 'a = ('a, 'b) #a
+    method a : 'a
+    method as_b : ('a, 'b) b
+  end
+type bt = 'a ca cb as 'a
+#     class c : object method m : int end
+# val f : unit -> c = <fun>
+# val f : unit -> c = <fun>
+# Characters 11-60:
+Warning: the following private methods were made public implicitly:
+  n
+val f : unit -> < m : int; n : int > = <fun>
+# Characters 11-56:
+This object is expected to have type c but has actually type
+  < m : int; n : 'a >
+Only the second object type has a method n
+# Characters 11-69:
+This object is expected to have type < n : int > but has actually type
+  < m : 'a >
+Only the first object type has a method n
+#         Characters 66-124:
+This object is expected to have type < x : int; .. > but has actually type
+  < x : int >
+Self type cannot be unified with a closed object type
+#         val o : < x : int > = <obj>
+#         Characters 76-77:
+This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a
+but is here used with type
+  < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) >
+Types for method m are incompatible
+#         Characters 176-177:
+This expression has type foo' = < m : 'a. 'a * 'a foo >
+but is here used with type bar' = < m : 'a. 'a * 'a bar >
+Type 'a foo = < m : 'a * 'a foo > is not compatible with type
+  'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > 
+Type 'a foo = < m : 'a * 'a foo > is not compatible with type
+  < m : 'b. 'b * 'a bar > 
+Types for method m are incompatible
+# 
diff --git a/testlabl/poly.ml b/testlabl/poly.ml
new file mode 100644
index 00000000..80c3bdbe
--- /dev/null
+++ b/testlabl/poly.ml
@@ -0,0 +1,488 @@
+(* $Id: poly.ml,v 1.27 2004/06/01 09:35:54 garrigue Exp $ *)
+(*
+   Polymorphic methods are now available in the main branch.
+   Enjoy.
+*)
+
+(* Tests for explicit polymorphism *)
+open StdLabels;;
+
+type 'a t = { t : 'a };;
+type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b };;
+let f l = { fold = List.fold_left l };;
+(f [1;2;3]).fold ~f:(+) ~init:0;;
+
+class ['b] ilist l = object
+  val l = l
+  method add x = {< l = x :: l >}
+  method fold : 'a. f:('a -> 'b -> 'a) -> init:'a -> 'a =
+    List.fold_left l
+end
+;;
+class virtual ['a] vlist = object (_ : 'self)
+  method virtual add : 'a -> 'self
+  method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
+end
+;;
+class ilist2 l = object
+  inherit [int] vlist
+  val l = l
+  method add x = {< l = x :: l >}
+  method fold = List.fold_left l
+end
+;;
+let ilist2 l = object
+  inherit [_] vlist
+  val l = l
+  method add x = {< l = x :: l >}
+  method fold = List.fold_left l
+end
+;;
+class ['a] ilist3 l = object
+  inherit ['a] vlist
+  val l = l
+  method add x = {< l = x :: l >}
+  method fold = List.fold_left l
+end
+;;
+class ['a] ilist4 (l : 'a list) = object
+  val l = l
+  method virtual add : _
+  method add x = {< l = x :: l >}
+  method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
+  method fold = List.fold_left l
+end
+;;
+class ['a] ilist5 (l : 'a list) = object (self)
+  val l = l
+  method add x = {< l = x :: l >}
+  method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
+  method virtual fold2 : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
+  method fold2 ~f ~init = self#fold ~f ~init:(self#fold ~f ~init)
+  method fold = List.fold_left l
+end
+;;
+class ['a] ilist6 l = object (self)
+  inherit ['a] vlist
+  val l = l
+  method add x = {< l = x :: l >}
+  method virtual fold2 : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
+  method fold2 ~f ~init = self#fold ~f ~init:(self#fold ~f ~init)
+  method fold = List.fold_left l
+end
+;;
+class virtual ['a] olist = object
+  method virtual fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c
+end
+;;
+class ['a] onil = object
+  inherit ['a] olist
+  method fold ~f ~init = init
+end
+;;
+class ['a] ocons ~hd ~tl = object (_ : 'b)
+  inherit ['a] olist
+  val hd : 'a = hd
+  val tl : 'a olist = tl
+  method fold ~f ~init = f hd (tl#fold ~f ~init)
+end
+;;
+class ['a] ostream ~hd ~tl = object (_ : 'b)
+  inherit ['a] olist
+  val hd : 'a = hd
+  val tl : _ #olist = (tl : 'a ostream)
+  method fold ~f ~init = f hd (tl#fold ~f ~init)
+  method empty = false
+end
+;;
+class ['a] ostream1 ~hd ~tl = object (self : 'b)
+  inherit ['a] olist
+  val hd = hd
+  val tl : 'b = tl
+  method hd = hd
+  method tl = tl
+  method fold ~f ~init =
+    self#tl#fold ~f ~init:(f self#hd init)
+end
+;;
+
+class vari = object
+  method virtual m : 'a. ([< `A|`B|`C] as 'a) -> int
+  method m = function `A -> 1 | `B|`C  -> 0
+end
+;;
+class vari = object
+  method m : 'a. ([< `A|`B|`C] as 'a) -> int = function `A -> 1 | `B|`C -> 0
+end
+;;
+module V =
+  struct
+    type v = [`A | `B | `C]
+    let m : [< v] -> int = function `A -> 1 | #v -> 0
+  end
+;;
+class varj = object
+  method virtual m : 'a. ([< V.v] as 'a) -> int
+  method m = V.m
+end
+;;
+
+module type T = sig
+  class vari : object method m : 'a. ([< `A | `B | `C] as 'a) -> int end
+end
+;;
+module M0 = struct
+  class vari = object
+    method virtual m : 'a. ([< `A|`B|`C] as 'a) -> int
+    method m = function `A -> 1 | `B|`C -> 0
+  end
+end
+;;
+module M : T = M0
+;;
+let v = new M.vari;;
+v#m `A;;
+
+class point ~x ~y = object
+  val x : int = x
+  val y : int = y
+  method x = x
+  method y = y
+end
+;;
+class color_point ~x ~y ~color = object
+  inherit point ~x ~y
+  val color : string = color
+  method color = color
+end
+;;
+class circle (p : #point) ~r = object
+  val p = (p :> point)
+  val r = r
+  method virtual distance : 'a. (#point as 'a) -> float
+  method distance p' =
+    let dx = p#x - p'#x and dy = p#y - p'#y in
+    let d = sqrt (float (dx * dx + dy * dy)) -. float r in
+    if d < 0. then 0. else d
+end
+;;
+let p0 = new point ~x:3 ~y:5
+let p1 = new point ~x:10 ~y:13
+let cp = new color_point ~x:12 ~y:(-5) ~color:"green"
+let c = new circle p0 ~r:2
+let d = c#distance cp
+;;
+let f (x : < m : 'a. 'a -> 'a >) = (x : < m : 'b. 'b -> 'b >)
+;;
+let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
+;;
+
+class id = object
+  method virtual id : 'a. 'a -> 'a
+  method id x = x
+end
+;;
+
+class type id_spec = object
+  method id : 'a -> 'a
+end
+;;
+class id_impl = object (_ : #id_spec)
+  method id x = x
+end
+;;
+
+class a = object
+  method m = (new b : id_spec)#id true
+end
+and b = object (_ : #id_spec)
+  method id x = x
+end
+;;
+
+class ['a] id1 = object
+  method virtual id : 'b. 'b -> 'a
+  method id x = x
+end
+;;
+class id2 (x : 'a) = object
+  method virtual id : 'b. 'b -> 'a
+  method id x = x
+end
+;;
+class id3 x = object
+  val x = x
+  method virtual id : 'a. 'a -> 'a
+  method id _ = x
+end
+;;
+class id4 () = object
+  val mutable r = None
+  method virtual id : 'a. 'a -> 'a
+  method id x =
+    match r with
+      None -> r <- Some x; x
+    | Some y -> y
+end
+;;
+class c = object
+  method virtual m : 'a 'b. 'a -> 'b -> 'a
+  method m x y = x
+end
+;;
+
+let f1 (f : id) = f#id 1, f#id true
+;;
+let f2 f = (f : id)#id 1, (f : id)#id true
+;;
+let f3 f = f#id 1, f#id true
+;;
+let f4 f = ignore(f : id); f#id 1, f#id true
+;;
+
+class c = object
+  method virtual m : 'a. (#id as 'a) -> int * bool
+  method m (f : #id) = f#id 1, f#id true
+end
+;;
+
+class id2 = object (_ : 'b)
+  method virtual id : 'a. 'a -> 'a
+  method id x = x
+  method mono (x : int) = x
+end
+;;
+let app = new c #m (new id2)
+;;
+type 'a foo = 'a foo list
+;;
+
+class ['a] bar (x : 'a) = object end
+;;
+type 'a foo = 'a foo bar
+;;
+
+fun x -> (x : < m : 'a. 'a * 'b > as 'b)#m;;
+fun x -> (x : < m : 'a. 'b * 'a list> as 'b)#m;;
+let f x = (x : < m : 'a. 'b * (< n : 'a; .. > as 'a) > as 'b)#m;;
+
+fun (x : < p : 'a. < m : 'a ; n : 'b ; .. > as 'a > as 'b) -> x#p;;
+
+type sum = T of < id: 'a. 'a -> 'a > ;;
+fun (T x) -> x#id;;
+
+type record = { r: < id: 'a. 'a -> 'a > } ;;
+fun x -> x.r#id;;
+fun {r=x} -> x#id;;
+
+class myself = object (self)
+  method self : 'a. 'a -> 'b = fun _ -> self
+end;;
+
+class number = object (self : 'self)
+  val num = 0
+  method num = num
+  method succ = {< num = num + 1 >}
+  method prev =
+    self#switch ~zero:(fun () -> failwith "zero") ~prev:(fun x -> x)
+  method switch : 'a. zero:(unit -> 'a) -> prev:('self -> 'a) -> 'a =
+    fun ~zero ~prev ->
+      if num = 0 then zero () else prev {< num = num - 1 >}
+end
+;;
+
+let id x = x
+;;
+class c = object
+  method id : 'a. 'a -> 'a = id
+end
+;;
+class c' = object
+  inherit c
+  method id = id
+end
+;;
+class d = object
+  inherit c as c
+  val mutable count = 0
+  method id x = count <- count+1; x
+  method count = count
+  method old : 'a. 'a -> 'a = c#id
+end
+;;
+class ['a] olist l = object
+  val l = l
+  method fold : 'b. f:('a -> 'b -> 'b) -> init:'b -> 'b
+      = List.fold_right l
+  method cons a = {< l = a :: l >}
+end
+;;
+let sum (l : 'a #olist) = l#fold ~f:(fun x acc -> x+acc) ~init:0
+;;
+let count (l : 'a #olist) = l#fold ~f:(fun _ acc -> acc+1) ~init:0
+;;
+let append (l : 'a #olist) (l' : 'b #olist) =
+  l#fold ~init:l' ~f:(fun x acc -> acc#cons x)
+;;
+
+type 'a t = unit
+;;
+class o = object method x : 'a. ([> `A] as 'a) t -> unit = fun _ -> () end
+;;
+
+class c = object method m = new d () end and d ?(x=0) () = object end;;
+class d ?(x=0) () = object end and c = object method m = new d () end;;
+
+class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
+class zero = object (_ : #numeral) method fold f x = x end
+class next (n : #numeral) =
+  object (_ : #numeral) method fold f x = n#fold f (f x) end
+;;
+
+class type node_type =  object
+  method as_variant : [> `Node of node_type]
+end;;
+class node : node_type = object (self)
+  method as_variant : 'a. [> `Node of node_type] as 'a
+                    = `Node (self :>  node_type)
+end;;
+class node = object (self : #node_type)
+  method as_variant = `Node (self :> node_type)
+end;;
+
+type bad = {bad : 'a. 'a option ref};;
+let bad = {bad = ref None};;
+type bad2 = {mutable bad2 : 'a. 'a option ref option};;
+let bad2 = {bad2 = None};;
+bad2.bad2 <- Some (ref None);;
+
+(* PR#1374 *)
+
+type 'a t= [`A of 'a];;
+class c = object (self)
+  method m :  'a. ([> 'a t] as 'a) -> unit
+    = fun x -> self#m x
+end;;
+class c = object (self)
+  method m : 'a. ([> 'a t] as 'a) -> unit = function
+    | `A x' -> self#m x'
+    | _ -> failwith "c#m"
+end;;
+class c = object (self)
+  method m :  'a. ([> 'a t] as 'a) -> 'a = fun x -> self#m x
+end;;
+
+(* usage avant instance *)
+class c = object method m : 'a. 'a option -> ([> `A] as 'a) = fun x -> `A end;;
+
+(* various old bugs *)
+class virtual ['a] visitor =
+object method virtual caseNil : 'a end
+and virtual int_list =
+object method virtual visit : 'a.('a visitor -> 'a) end;;
+
+type ('a,'b) list_visitor = < caseNil : 'a; caseCons : 'b -> 'b list -> 'a >
+type 'b alist = < visit : 'a. ('a,'b) list_visitor -> 'a >
+
+(* PR#1607 *)
+class type ct = object ('s)
+  method fold : ('b -> 's -> 'b) -> 'b -> 'b
+end
+type t = {f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b};;
+
+(* PR#1663 *)
+type t = u and u = t;;
+
+(* PR#1731 *)
+class ['t] a = object constraint 't = [> `A of 't a] end
+type t = [ `A of t a ];;
+
+(* Wrong in 3.06 *)
+type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
+
+(* Full polymorphism if we do not expand *)
+type 'a t = 'a and u = int t;;
+
+(* Loose polymorphism if we expand *)
+type 'a t constraint 'a = int;;
+type 'a u = 'a and 'a v = 'a u t;;
+type 'a u = 'a and 'a v = 'a u t constraint 'a = int;;
+
+(* Behaviour is unstable *)
+type g = int;;
+type 'a t = unit constraint 'a = g;;
+type 'a u = 'a and 'a v = 'a u t;;
+type 'a u = 'a and 'a v = 'a u t constraint 'a = int;;
+
+(* Example of wrong expansion *)
+type 'a u = < m : 'a v > and 'a v = 'a list u;;
+
+(* PR#1744: Ctype.matches *)
+type 'a t = 'a
+type 'a u = A of 'a t;;
+
+(* Unification of cyclic terms *)
+type 'a t = < a : 'a >;;
+fun (x : 'a t as 'a) -> (x : 'b t);;
+type u = 'a t as 'a;;
+
+
+(* Variant tests *)
+type t = A | B;;
+function `A,_ -> 1 | _,A -> 2 | _,B -> 3;;
+function `A,_ -> 1 | _,(A|B) -> 2;;
+function Some `A, _ -> 1 | Some _, A -> 2 | None, A -> 3 | _, B -> 4;;
+function Some `A, A -> 1 | Some `A, B -> 1
+       | Some _, A -> 2  | None, A -> 3 | _, B -> 4;;
+function A, `A -> 1 | A, `B -> 2 | B, _ -> 3;;
+function `A, A -> 1 | `B, A -> 2 | _, B -> 3;;
+function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
+function `B,1 -> 1 | _,1 -> 2;;
+function 1,`B -> 1 | 1,_ -> 2;;
+
+(* pass typetexp, but fails during Typedecl.check_recursion *)
+type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] 
+and  ('a, 'b) b = 'b -> unit constraint 'b = [> `A of ('a, 'b) a as 'a];;
+
+(* PR#1917: expanding may change original in Ctype.unify2 *)
+class type ['a, 'b] a = object
+  method b: ('a, 'b) #b as 'b
+  method as_a: ('a, 'b) a
+end and ['a, 'b] b = object
+  method a: ('a, 'b) #a as 'a
+  method as_b: ('a, 'b) b 
+end
+
+class type ['b] ca = object ('s) inherit ['s, 'b] a end
+class type ['a] cb = object ('s) inherit ['a, 's] b end
+	  
+type bt = 'b ca cb as 'b
+;;
+
+(* final classes, etc... *)
+class c = object method m = 1 end;;
+let f () = object (self:c) method m = 1 end;;
+let f () = object (self:c) method private n = 1 method m = self#n end;;
+let f () = object method private n = 1 method m = {<>}#n end;;
+let f () = object (self:c) method n = 1 method m = 2 end;;
+let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;;
+class c = object (_ : 's)
+  method x = 1
+  method private m =
+    object (self: 's) method x = 3 method private m = self end
+end;;
+let o = object (_ : 's)
+  method x = 1
+  method private m =
+    object (self: 's) method x = 3 method private m = self end
+end;;
+
+
+(* Unsound! *)
+fun (x : <m : 'a. 'a * <m: 'b. 'a * 'foo> > as 'foo) ->
+  (x : <m : 'a. 'a * (<m:'b. 'a * <m:'c. 'c * 'bar> > as 'bar) >);;
+type 'a foo = <m: 'b. 'a * 'a foo>
+type foo' =   <m: 'a. 'a * 'a foo>
+type 'a bar = <m: 'b. 'a * <m: 'c. 'c * 'a bar> >
+type bar' =   <m: 'a. 'a * 'a bar >
+let f (x : foo') = (x : bar');;
diff --git a/testlabl/printers.ml b/testlabl/printers.ml
new file mode 100644
index 00000000..2d06b4c6
--- /dev/null
+++ b/testlabl/printers.ml
@@ -0,0 +1,11 @@
+(* $Id: printers.ml,v 1.1 2003/04/03 02:16:20 garrigue Exp $ *)
+
+open Types
+
+let ignore_abbrevs ppf ab =
+  let s = match ab with
+    Mnil -> "Mnil"
+  | Mlink _ -> "Mlink _"
+  | Mcons _ -> "Mcons _"
+  in
+  Format.pp_print_string ppf s
diff --git a/testlabl/tests.ml b/testlabl/tests.ml
new file mode 100644
index 00000000..daea8e04
--- /dev/null
+++ b/testlabl/tests.ml
@@ -0,0 +1,22 @@
+(* $Id: tests.ml,v 1.3 2000/01/07 16:44:44 doligez Exp $ *)
+
+let f1 = function `a x -> x=1 | `b -> true
+let f2 = function `a x -> x | `b -> true
+let f3 = function `b -> true
+let f x = f1 x && f2 x
+
+let sub s ?:pos{=0} ?:len{=String.length s - pos} () =
+  String.sub s pos len
+
+let cCAMLtoTKpack_options w = function
+        `After v1 -> "-after"
+        | `Anchor v1 -> "-anchor"
+        | `Before v1 -> "-before"
+        | `Expand v1 -> "-expand"
+        | `Fill v1 -> "-fill"
+        | `In v1 -> "-in"
+        | `Ipadx v1 -> "-ipadx"
+        | `Ipady v1 -> "-ipady"
+        | `Padx v1 -> "-padx"
+        | `Pady v1 -> "-pady"
+        | `Side v1 -> "-side"
diff --git a/testobjects/.cvsignore b/testobjects/.cvsignore
new file mode 100644
index 00000000..9c92a72e
--- /dev/null
+++ b/testobjects/.cvsignore
@@ -0,0 +1 @@
+*.proc
diff --git a/testobjects/Exemples.exp b/testobjects/Exemples.exp
new file mode 100644
index 00000000..5d55e083
--- /dev/null
+++ b/testobjects/Exemples.exp
@@ -0,0 +1,301 @@
+#           class point (int) =
+  val mutable x : int
+  method get_x : int
+  method move : int -> unit
+end
+#   val p : point = <obj>
+#   - : int = 7
+# - : unit = ()
+# - : int = 10
+#   val q : point = <obj>
+#   - : int * int = 10, 17
+#           class color_point (int) (string) =
+  val c : string
+  val mutable x : int
+  method color : string
+  method get_x : int
+  method move : int -> unit
+end
+#   val p' : color_point = <obj>
+#   - : int * string = 5, "red"
+#   val l : point list = [<obj>; <obj>]
+#   val get_x : < get_x : 'a; .. > -> 'a = <fun>
+# val set_x : < set_x : 'a; .. > -> 'a = <fun>
+# - : int list = [10; 5]
+#           Characters 6-86:
+The type variable 'a is not bound in implicit type definition
+  ref = < get : 'a; set : 'a -> unit >
+It should be captured by a class type parameter
+#           class ref (int) =
+  val mutable x : int
+  method get : int
+  method set : int -> unit
+end
+#           class 'a ref ('a) =
+  val mutable x : 'a
+  method get : 'a
+  method set : 'a -> unit
+end
+#   - : int = 2
+#             class 'a circle ('a) =
+  constraint 'a = < move : int -> unit; .. >
+  val mutable center : 'a
+  method center : 'a
+  method move : int -> unit
+  method set_center : 'a -> unit
+end
+#               class 'a circle ('a) =
+  constraint 'a = #point
+  val mutable center : 'a
+  method center : 'a
+  method move : int -> unit
+  method set_center : 'a -> unit
+end
+#   val c : point circle = <obj>
+val c' : color_point circle = <obj>
+#           class 'a color_circle ('a) =
+  constraint 'a = #color_point
+  val mutable center : 'a
+  method center : 'a
+  method color : string
+  method move : int -> unit
+  method set_center : 'a -> unit
+end
+#   Characters 28-29:
+This expression has type point = < get_x : int; move : int -> unit >
+but is here used with type
+  #color_point = < get_x : int; move : int -> unit; color : string; .. >
+# val c'' : color_point color_circle = <obj>
+#   - : color_point circle = <obj>
+# Characters 1-4:
+This expression cannot be coerced to type
+  point circle =
+    < center : point; set_center : point -> unit; move : int -> unit >;
+it has type
+  color_point color_circle =
+    < center : color_point; set_center : color_point -> unit;
+      move : int -> unit; color : string >
+but is here used with type
+  < center : color_point; set_center : point -> unit; move : int -> unit;
+    color : string >
+Type color_point = < get_x : int; move : int -> unit; color : string >
+is not compatible with type point = < get_x : int; move : int -> unit >
+# Characters 9-55:
+Type
+  color_point color_circle =
+    < center : color_point; set_center : color_point -> unit;
+      move : int -> unit; color : string >
+is not a subtype of type
+  point circle =
+    < center : point; set_center : point -> unit; move : int -> unit >
+Type color_point -> unit is not a subtype of type point -> unit
+Type point = < get_x : int; move : int -> unit > is not a subtype of type
+  color_point = < get_x : int; move : int -> unit; color : string >
+#         class printable_point (int) =
+  val mutable x : int
+  method get_x : int
+  method move : int -> unit
+  method print : unit
+end
+#   val p : printable_point = <obj>
+# 7- : unit = ()
+#                     class printable_color_point (int) (string) =
+  val c : string
+  val mutable x : int
+  method color : string
+  method get_x : int
+  method move : int -> unit
+  method print : unit
+end
+#   val p' : printable_color_point = <obj>
+# (7, red)- : unit = ()
+#           class functional_point (int) : 'a =
+  val x : int
+  method get_x : int
+  method move : int -> 'a
+end
+#   val p : functional_point = <obj>
+#   - : int = 7
+# - : int = 10
+# - : int = 7
+#   - : (< get_x : int; move : int -> 'a; .. > as 'a) -> functional_point = <fun>
+#                                                                       class virtual 'a lst (unit) =
+  virtual hd : 'a
+  method iter : ('a -> unit) -> unit
+  method map : ('a -> 'a) -> 'a lst
+  virtual null : bool
+  method print : ('a -> unit) -> unit
+  virtual tl : 'a lst
+end
+class 'a nil (unit) =
+  method hd : 'a
+  method iter : ('a -> unit) -> unit
+  method map : ('a -> 'a) -> 'a lst
+  method null : bool
+  method print : ('a -> unit) -> unit
+  method tl : 'a lst
+end
+class 'a cons ('a) ('a lst) =
+  val h : 'a
+  val t : 'a lst
+  method hd : 'a
+  method iter : ('a -> unit) -> unit
+  method map : ('a -> 'a) -> 'a lst
+  method null : bool
+  method print : ('a -> unit) -> unit
+  method tl : 'a lst
+end
+#   val l1 : int cons = <obj>
+#   (3::10::[])- : unit = ()
+#   val l2 : int lst = <obj>
+# (4::11::[])- : unit = ()
+#       val map_list : ('a -> 'b) -> 'a lst -> 'b lst = <fun>
+#   val p1 : printable_color_point lst = <obj>
+# ((3, red)::(10, red)::[])- : unit = ()
+#           class virtual comparable (unit) : 'a = virtual leq : 'a -> bool end
+#             class int_comparable (int) : 'a =
+  val x : int
+  method leq : 'a -> bool
+  method x : int
+end
+#           class int_comparable2 (int) : 'a =
+  method leq : 'a -> bool
+  method set_x : int -> unit
+  method x : int
+end
+#                         class 'a sorted_list (unit) =
+  constraint 'a = #comparable
+  val mutable l : 'a list
+  method add : 'a -> unit
+  method hd : 'a
+end
+#   val l : _#comparable sorted_list = <obj>
+# val c : int_comparable = <obj>
+# - : unit = ()
+#   val c2 : int_comparable2 = <obj>
+# Characters 7-9:
+This expression cannot be coerced to type
+  int_comparable = < leq : int_comparable -> bool; x : int >;
+it has type
+  int_comparable2 =
+    < leq : int_comparable2 -> bool; x : int; set_x : int -> unit >
+but is here used with type
+  < leq : int_comparable -> bool; x : int; set_x : int -> unit >
+Type
+  int_comparable2 =
+    < leq : int_comparable2 -> bool; x : int; set_x : int -> unit >
+is not compatible with type
+  int_comparable = < leq : int_comparable -> bool; x : int >
+# - : unit = ()
+#             class int_comparable3 (int) =
+  val mutable x : int
+  method leq : int_comparable -> bool
+  method setx : int -> unit
+  method x : int
+end
+#   val c3 : int_comparable3 = <obj>
+# - : unit = ()
+# Characters 25-27:
+This expression has type
+  int_comparable3 =
+    < leq : int_comparable -> bool; x : int; setx : int -> unit >
+but is here used with type
+  < leq : 'a -> bool; setx : int -> unit; x : int > as 'a
+Type int_comparable = < leq : int_comparable -> bool; x : int >
+is not compatible with type
+  int_comparable3 =
+    < leq : int_comparable -> bool; x : int; setx : int -> unit >
+#   val sort : (#comparable as 'a) list -> 'a list = <fun>
+#     val pr : < x : int; .. > list -> unit = <fun>
+#   val l : int_comparable list = [<obj>; <obj>; <obj>]
+# 5 2 4 
+- : unit = ()
+# 2 4 5 
+- : unit = ()
+# val l : int_comparable2 list = [<obj>; <obj>]
+# 2 0 
+- : unit = ()
+# 0 2 
+- : unit = ()
+#     val min : (#comparable as 'a) -> 'a -> 'a = <fun>
+#   - : int = 7
+# - : int = 3
+#                                 class 'a link ('a) : 'b =
+  val mutable next : 'b option
+  val mutable x : 'a
+  method append : 'b option -> unit
+  method next : 'b option
+  method set_next : 'b option -> unit
+  method set_x : 'a -> unit
+  method x : 'a
+end
+#                   class 'a double_link ('a) : 'b =
+  val mutable next : 'b option
+  val mutable prev : 'b option
+  val mutable x : 'a
+  method append : 'b option -> unit
+  method next : 'b option
+  method prev : 'b option
+  method set_next : 'b option -> unit
+  method set_prev : 'b option -> unit
+  method set_x : 'a -> unit
+  method x : 'a
+end
+#           val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = <fun>
+#                                       class calculator (unit) : 'a =
+  val mutable acc : float
+  val mutable arg : float
+  val mutable equals : 'a -> float
+  method acc : float
+  method add : 'a
+  method arg : float
+  method enter : float -> 'a
+  method equals : float
+  method sub : 'a
+end
+#   - : float = 5
+# - : float = 1.5
+# - : float = 15
+#                       class calculator (unit) : 'a =
+  val mutable acc : float
+  val mutable arg : float
+  val mutable equals : 'a -> float
+  method acc : float
+  method add : 'a
+  method arg : float
+  method enter : float -> 'a
+  method equals : float
+  method sub : 'a
+end
+#   - : float = 5
+# - : float = 1.5
+# - : float = 15
+#                                 class calculator (float) (float) =
+  val acc : float
+  val arg : float
+  method add : calculator_add
+  method enter : float -> calculator
+  method equals : float
+  method sub : calculator_sub
+end
+class calculator_add (float) (float) =
+  val acc : float
+  val arg : float
+  method add : calculator_add
+  method enter : float -> calculator
+  method equals : float
+  method sub : calculator_sub
+end
+class calculator_sub (float) (float) =
+  val acc : float
+  val arg : float
+  method add : calculator_add
+  method enter : float -> calculator
+  method equals : float
+  method sub : calculator_sub
+end
+#   val calculator : calculator = <obj>
+#   - : float = 5
+# - : float = 1.5
+# - : float = 15
+# 
diff --git a/testobjects/Exemples.ml b/testobjects/Exemples.ml
new file mode 100644
index 00000000..30db53ab
--- /dev/null
+++ b/testobjects/Exemples.ml
@@ -0,0 +1,333 @@
+
+class point x_init =
+  val mutable x = x_init
+  method get_x = x
+  method move d = x <- x + d
+end;;
+
+let p = new point 7;;
+
+p#get_x;;
+p#move 3;;
+p#get_x;;
+
+let q = Oo.copy p;;
+
+q#move 7; p#get_x, q#get_x;;
+
+class color_point x (c : string) =
+  inherit point x
+  val c = c
+  method color = c
+end;;
+
+let p' = new color_point 5 "red";;
+
+p'#get_x, p'#color;;
+
+let l = [p; (p' :> point)];;
+
+let get_x p = p#get_x;;
+let set_x p = p#set_x;;
+List.map get_x l;;
+
+class ref x_init = 
+  val mutable x = x_init
+  method get = x
+  method set y = x <- y
+end;;
+
+class ref (x_init:int) = 
+  val mutable x = x_init
+  method get = x
+  method set y = x <- y
+end;;
+
+class 'a ref x_init = 
+  val mutable x = (x_init : 'a)
+  method get = x
+  method set y = x <- y
+end;;
+
+let r = new ref 1 in r#set 2; (r#get);;
+
+class 'a circle (c : 'a) =
+  val mutable center = c
+  method center = center
+  method set_center c = center <- c
+  method move = (center#move : int -> unit)
+end;;
+
+class 'a circle (c : 'a) =
+  constraint 'a = #point
+  val mutable center = c
+  method center = center
+  method set_center c = center <- c
+  method move = center#move
+end;;
+
+let (c, c') = (new circle p, new circle p');;
+
+class 'a color_circle c =
+  constraint 'a = #color_point
+  inherit ('a) circle c
+  method color = center#color
+end;;
+
+let c'' = new color_circle p;;
+let c'' = new color_circle p';;
+
+(c'' :> color_point circle);;
+(c'' :> point circle);;                 (* Echec *)
+fun x -> (x : color_point color_circle :> point circle);;
+
+class printable_point y as s =
+  inherit point y
+  method print = print_int s#get_x
+end;;
+
+let p = new printable_point 7;;
+p#print;;
+
+class printable_color_point y c as self =
+  inherit color_point y c
+  inherit printable_point y as super
+  method print =
+    print_string "(";
+    super#print;
+    print_string ", ";
+    print_string (self#color);
+    print_string ")"
+end;;
+
+let p' = new printable_color_point 7 "red";;
+p'#print;;
+
+class functional_point y =
+  val x = y
+  method get_x = x
+  method move d = {< x = x + d >}
+end;;
+
+let p = new functional_point 7;;
+
+p#get_x;;
+(p#move 3)#get_x;;
+p#get_x;;
+
+fun x -> (x :> functional_point);;
+
+(*******************************************************************)
+
+class virtual 'a lst () as self =
+  virtual null : bool
+  virtual hd : 'a
+  virtual tl : 'a lst
+  method map f =
+    (if self#null then
+       new nil ()
+     else
+       new cons (f self#hd) (self#tl#map f)
+     : 'a lst)
+  method iter (f : 'a -> unit) =
+    if self#null then ()
+    else begin
+      f self#hd;
+      self#tl#iter f
+    end
+  method print (f : 'a -> unit) = 
+    print_string "(";
+    self#iter (fun x -> f x; print_string "::");
+    print_string "[]";
+    print_string ")"
+and 'a nil () =
+  inherit ('a) lst ()
+  method null = true
+  method hd   = failwith "hd"
+  method tl   = failwith "tl"
+and 'a cons h t =
+  inherit ('a) lst ()
+  val h = h val t = t
+  method null = false
+  method hd   = h
+  method tl   = t
+end;;
+
+let l1 = new cons 3 (new cons 10 (new nil ()));;
+
+l1#print print_int;;
+
+let l2 = l1#map (fun x -> x + 1);;
+l2#print print_int;;
+
+let rec map_list f (x:'a lst) = 
+  if x#null then new nil() 
+  else new cons (f x#hd) (map_list f x#tl);;
+
+let p1 = (map_list (fun x -> new printable_color_point x "red") l1);;
+p1#print (fun x -> x#print);;
+
+(*******************************************************************)
+
+class virtual comparable () : 'a =
+  virtual leq : 'a -> bool
+  end;;
+
+class int_comparable (x : int) =
+  inherit comparable ()
+  val x = x
+  method x = x
+  method leq p = x <= p#x
+end;;
+
+class int_comparable2 x =
+  inherit int_comparable x
+  val private mutable x
+  method set_x y = x <- y
+end;;
+
+class 'a sorted_list () =
+  constraint 'a = #comparable
+  val mutable l = ([] : 'a list)
+  method add x =
+    let rec insert =
+      function
+            []     ->  [x]
+      | a::l as l' -> if a#leq x then a::(insert l) else x::l'
+    in
+      l <- insert l
+  method hd = List.hd l
+end;;
+
+let l = new sorted_list ();;
+let c = new int_comparable 10;;
+l#add c;;
+
+let c2 = new int_comparable2 15;;
+l#add (c2 :> int_comparable);;      (* Echec : 'a comp2 n'est un sous-type *)
+(new sorted_list ())#add c2;;
+
+class int_comparable3 (x : int) =
+  val mutable x = x
+  method leq (y : int_comparable) = x < y#x
+  method x = x
+  method setx y = x <- y
+end;;
+
+let c3 = new int_comparable3 15;;
+l#add (c3 :> int_comparable);;
+(new sorted_list ())#add c3;;   (* Echec : leq n'est pas binaire *)
+
+let sort (l : #comparable list) = Sort.list (fun x -> x#leq) l;;
+let pr l =
+  List.map (fun c -> print_int c#x; print_string " ") l;
+  print_newline ();;
+let l = [new int_comparable 5; (new int_comparable3 2 :> int_comparable);
+         new int_comparable 4];;
+pr l;;
+pr (sort l);;
+let l = [new int_comparable2 2; new int_comparable2 0];;
+pr l;;
+pr (sort l);;
+
+let min (x : #comparable) y =
+  if x#leq y then x else y;;
+
+(min (new int_comparable  7) (new int_comparable 11))#x;;
+(min (new int_comparable2 5) (new int_comparable2 3))#x;;
+
+(*******************************************************************)
+
+class 'a link (x : 'a) as self : 'b =
+  val mutable x = x
+  val mutable next = (None : 'b option)
+  method x = x
+  method  next = next
+  method  set_x y = x <- y
+  method  set_next l = next <- l
+  method  append l =
+    match next with
+      None ->
+        self#set_next l
+    | Some l' ->
+        l'#append l
+end;;
+
+class 'a double_link x as self =
+  inherit ('a) link x
+  val mutable prev = None
+  method prev = prev
+  method  set_next l =
+         next <- l;
+         match l with Some l -> l#set_prev (Some self) | None -> ()
+  method  set_prev l = prev <- l
+end;;
+
+let rec fold_right f (l : 'a #link option) accu =
+  match l with
+    None -> accu
+  | Some l ->
+      f l#x (fold_right f l#next accu);;
+
+(*******************************************************************)
+
+class calculator () as self =
+  val mutable arg = 0.
+  val mutable acc = 0.
+  val mutable equals = function s -> s#arg
+  method arg = arg
+  method acc = acc
+  method enter n = arg <- n; self
+  method add =
+    acc <- equals self;
+    equals <- (function s -> s#acc +. s#arg);
+    self
+  method sub =
+    acc <- equals self;
+    equals <- (function s -> s#acc -. s#arg);
+    self
+  method equals = equals self
+end;;
+
+((new calculator ())#enter 5.)#equals;;
+(((new calculator ())#enter 5.)#sub#enter 3.5)#equals;;
+((new calculator ())#enter 5.)#add#add#equals;;
+
+class calculator () as self =
+  val mutable arg = 0.
+  val mutable acc = 0.
+  val mutable equals = function s -> s#arg
+  method arg = arg
+  method acc = acc
+  method enter n = arg <- n; self
+  method add = {< acc = equals self; equals = function s -> s#acc +. s#arg >}
+  method sub = {< acc = equals self; equals = function s -> s#acc -. s#arg >}
+  method equals = equals self
+end;;
+
+((new calculator ())#enter 5.)#equals;;
+(((new calculator ())#enter 5.)#sub#enter 3.5)#equals;;
+((new calculator ())#enter 5.)#add#add#equals;;
+
+class calculator arg acc as self =
+  val arg = arg
+  val acc = acc
+  method enter n = new calculator n acc
+  method add = new calculator_add arg self#equals
+  method sub = new calculator_sub arg self#equals
+  method equals = arg
+and calculator_add arg acc =
+  inherit calculator arg acc
+  method enter n = new calculator_add n acc
+  method equals = acc +. arg
+and calculator_sub arg acc =
+  inherit calculator arg acc
+  method enter n = new calculator_sub n acc
+  method equals = acc -. arg
+end;;
+
+let calculator = new calculator 0. 0.;;
+
+(calculator#enter 5.)#equals;;
+((calculator#enter 5.)#sub#enter 3.5)#equals;;
+(calculator#enter 5.)#add#add#equals;;
diff --git a/testobjects/Makefile b/testobjects/Makefile
new file mode 100644
index 00000000..8470f901
--- /dev/null
+++ b/testobjects/Makefile
@@ -0,0 +1,25 @@
+#########################################################################
+#                                                                       #
+#                            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 1999/11/17 18:58:45 xleroy Exp $
+
+# ocaml must be installed...
+
+test: Tests Exemples
+
+Tests:
+	TERM=dumb ../ocaml < Tests.ml | tail +3 > Tests.proc
+	- diff Tests.exp Tests.proc
+
+Exemples:
+	TERM=dumb ../ocaml < Exemples.ml | tail +3 > Exemples.proc
+	- diff Exemples.exp Exemples.proc
diff --git a/testobjects/Tests.exp b/testobjects/Tests.exp
new file mode 100644
index 00000000..c28ef5ad
--- /dev/null
+++ b/testobjects/Tests.exp
@@ -0,0 +1,228 @@
+#   - : < x : int > ->
+    < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int >
+= <fun>
+#               class 'a c (unit) = constraint 'a = int method f : 'a c end
+class 'a d (unit) = method f : int c end
+#                 Characters 185-212:
+The type variable 'a is not bound in implicit type definition
+  d = < f : 'a -> unit >
+It should be captured by a class type parameter
+#             class virtual closed c ('a) : 'a = virtual f : int end
+class virtual closed d ('a) : 'a = virtual f : int end
+#     class virtual closed e ('a) : 'a = virtual f : int end
+#           class virtual closed c (c) = end
+#             class virtual c (unit) = end
+class 'a d (unit) = constraint 'a = < x : int; .. > method f : 'a -> int end
+#               class 'a c (unit) = constraint 'a = int end
+class 'a d (unit) = constraint 'a = int #c end
+#               class closed 'a c ('a) : 'a =
+  constraint 'a = < f : 'a c >
+  method f : 'a c
+end
+# - : (< f : 'a c > as 'a) c -> (< f : 'b c > as 'b) c = <fun>
+#           Characters 118-143:
+The class x should be virtual: its method f is undefined
+#               Characters 184-187:
+The class d inherits from the closed class c which has no method g
+#           Characters 37-97:
+The abbreviation c is used with parameters bool c
+wich are incompatible with constraints int c 
+#             class ('a, 'b) c (unit) =
+  constraint 'a = int -> 'c
+  constraint 'b = 'a * < x : 'b > * 'c * 'd
+  method f : 'a -> 'b -> unit
+end
+#     class ('a, 'b) d (unit) =
+  constraint 'a = int -> 'c
+  constraint 'b = 'a * < x : 'b > * 'c * 'd
+  method f : 'a -> 'b -> unit
+end
+#     val x : '_a list ref = {contents=[]}
+#     Characters 5-37:
+The type parameters of this class contains type variables that cannot be
+generalized: '_a list ref c
+#       type 'a c = < f : 'a c; g : 'a d > constraint 'a = int
+type 'a d = < f : 'a c > constraint 'a = int
+#   type 'a c = < f : 'a c; g : 'a d >
+type 'a d = < f : 'a c >
+#   type 'a c = < f : 'a c > constraint 'a = int
+type 'a d = < f : int c >
+#   type 'a u = < x : 'a > constraint 'a = 'b t
+type 'a t = 'a t u
+#   Characters 19-32:
+The type abbreviation t is cyclic
+# type 'a u = 'a
+# Characters 4-18:
+The type abbreviation t is cyclic
+#   type t = < x : t >
+# type 'a u = 'a
+# - : t -> t u -> bool = <fun>
+# - : t -> t u -> bool = <fun>
+#                         module M :
+  sig
+    class ('a, 'b) c ('c) ('b) =
+      constraint 'a = int -> bool
+      val x : 'd list
+      val y : 'b
+      method f : 'a -> unit
+      method g : 'b
+    end
+  end
+#                   module M' :
+  sig
+    class virtual ('a, 'b) c (int) ('b) =
+      constraint 'a = int -> bool
+      val x : float list
+      val y : 'b
+      method f : 'a -> unit
+      method g : 'b
+    end
+  end
+# class ('a, 'b) d (unit) ('b) =
+  constraint 'a = int -> bool
+  val x : 'c list
+  val y : 'b
+  method f : 'a -> unit
+  method g : 'b
+end
+# class ('a, 'b) e (unit) ('b) =
+  constraint 'a = int -> bool
+  val x : float list
+  val y : 'b
+  method f : 'a -> unit
+  method g : 'b
+end
+# - : string = "a"
+# Characters 1-9:
+One cannot create instances of the virtual class M'.c
+# - : int = 10
+# - : float = 7.1
+# # - : bool = true
+#     module M : sig class closed 'a c (unit) = method f : 'a -> unit end end
+#   module M' : sig class closed 'a c (unit) = method f : 'a -> unit end end
+# - : < f : 'a -> unit; .. > -> 'a M.c = <fun>
+# - : < f : 'a -> unit; .. > -> 'a M'.c = <fun>
+# class 'a c ('b #c) = end
+# class closed 'a c ('a c) = end
+#     class c (unit) = method f : int end
+class d (unit) = method f : int end
+# class e (unit) = method f : int end
+# - : int = 2
+# Characters 23-27:
+This expression has type bool but is here used with type int
+#   class c (unit) = method f : int method g : int method h : int end
+# class d (unit) = method h : int method i : int method j : int end
+#               class e (unit) =
+  method f : int
+  method g : int
+  method h : int
+  method i : int
+  method j : int
+end
+# val e : e = <obj>
+# - : int * int * int * int * int = 1, 3, 2, 2, 3
+#   class c ('a) = val a : 'a val x : int val y : int val z : int end
+# class d ('a) = val b : 'a val t : int val u : int val z : int end
+#                             class e (unit) =
+  val a : int
+  val b : int
+  val t : int
+  val u : int
+  val x : int
+  val y : int
+  val z : int
+  method a : int
+  method b : int
+  method t : int
+  method u : int
+  method x : int
+  method y : int
+  method z : int
+end
+# val e : e = <obj>
+# - : int * int * int * int * int * int * int = 1, 3, 2, 2, 3, 5, 7
+#             class c (int) (int) =
+  val x : int
+  val y : int
+  method x : int
+  method y : int
+end
+# class d (int) (int) =
+  val x : int
+  val y : int
+  method x : int
+  method y : int
+end
+# - : int * int = 1, 2
+# - : int * int = 1, 2
+#     class 'a c ('a) = end
+# - : 'a -> 'a c = <fun>
+#           module type M =
+  sig class c (unit) = val x : int end class d (unit) = val x : bool end end
+#         class c (int) = method get : int method set : int -> unit end
+# val c : c = <obj>
+# - : int = 5
+# - : int = 7
+#   class c (unit) = val x : int val y : int method c : int end
+# class d (unit) = val y : int method c : int method d : int end
+#     class e (unit) =
+  val x : int
+  val y : int
+  method c : int
+  method d : int
+  method x : int
+  method y : int
+end
+# - : int * int * int * int = 2, 1, 1, 1
+#                           module M : sig class c (unit) = method xc : int end end
+#         class d (unit) = val x : int method xc : int method xd : int end
+# - : int * int = 1, 2
+#         Characters 7-143:
+The type variable 'a is not bound in implicit type definition
+  'b matrix = < add : 'b matrix -> 'b; m : 'a >
+It should be captured by a class type parameter
+#   class c (unit) = method m : c end
+# - : c = <obj>
+# module M : sig class c (unit) = method m : c end end
+# - : M.c = <obj>
+#   type uu = | A of int | B of (< leq : 'a > as 'a)
+#   class virtual c (unit) : 'a = virtual m : 'a end
+#         module S : sig val f : (#c as 'a) -> 'a end
+#         Characters 12-43:
+Signature mismatch:
+Modules do not match:
+  sig val f : (#c as 'a) -> 'a end
+is not included in
+  sig val f : #c -> #c end
+Values do not match:
+  val f : (#c as 'a) -> 'a
+is not included in
+  val f : #c -> #c
+#   Characters 32-48:
+Multiple definition of the type name t.
+Names must be unique in a given structure.
+#   - : (< m : (< m : 'b -> 'b > as 'b) -> 'a; .. > as 'a) ->
+    (< m : 'c -> 'c > as 'c)
+= <fun>
+#   Characters 10-39:
+Type int -> bool is not a subtype of type int -> int
+Type bool is not a subtype of type int
+# Characters 9-40:
+Type int -> bool is not a subtype of type int -> int
+Type bool is not a subtype of type int
+# - : <  > -> <  > = <fun>
+# - : < .. > -> <  > = <fun>
+#   val x : '_a list ref = {contents=[]}
+#   module F : functor(X : sig end) -> sig type t = int end
+# - : < m : int > list ref = {contents=[]}
+#   type 'a t
+# - : ('a t as 'a) -> unit = <fun>
+# - : ('a t as 'a) -> unit = <fun>
+# type 'a t = < x : 'a >
+# - : (< x : 'a > as 'a) t -> unit = <fun>
+# - : (< x : 'a > as 'a) t -> unit = <fun>
+#         class c (unit) = private method m : int method n : int end
+#         class d (unit) = private method m : int method n : int method o : int end
+#   - : int * int = 1, 1
+#   class c (unit) = method m : int end
+# 
diff --git a/testobjects/Tests.ml b/testobjects/Tests.ml
new file mode 100644
index 00000000..29051fa7
--- /dev/null
+++ b/testobjects/Tests.ml
@@ -0,0 +1,316 @@
+(* Le sous-typage est "syntaxique" *)
+fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);;
+(* - : (< x : int > as 'a) -> 'a -> 'a * 'a = <fun> *)
+
+(* Bizarrerie du typage des classes *)
+class 'a c () =
+  method f = (new c (): int c)
+and 'a d () =
+  inherit ('a) c ()
+end;;
+(* class 'a c (unit) = constraint 'a = int method f : 'a c end *)
+(* class 'a d (unit) method f : int c end *)
+
+(* 'a libre dans classe d *)
+class 'a c () =
+  method f (x : 'a) = ()
+and d () =
+  inherit ('a) c ()
+end;;
+
+(* Ferme self ! *)
+(* Pas vraiment moyen de garder l'abbreviation en parametre *)
+class virtual closed c ((x : 'a): < f : int >) : 'a =
+and virtual closed d ((x : 'a): < f : int >) : 'a =
+  inherit c x
+end;;
+class virtual closed e x =
+  inherit d x
+end;;
+(* class virtual closed c (< f : int >) = virtual f : int end *)
+(* class virtual closed d (< f : int >) = virtual f : int end *)
+(* class virtual closed e (< f : int >) = virtual f : int end *)
+
+(* Self unifie avec une abreviation *)
+class virtual closed c ((x : 'a) : c) : 'a = end;;
+
+(* Instancie #c *)
+class virtual c () =
+and 'a d () =
+  constraint 'a = #c
+  method f (x : #c) = (x#x : int)
+end;;
+(* class virtual c (unit) = end
+   class 'a d (unit) = constraint 'a = < x: int; .. > method f : 'a -> int end *)
+
+class 'a c () =
+  constraint 'a = int
+and 'a d () =
+  constraint 'a = 'b #c
+end;;
+(* class 'a c (unit) = constraint 'a = int end
+   class 'a d (unit) = constraint 'a = int #c end *)
+
+(* Self en parametre *)
+class closed 'a c (x : 'a) as self : 'b =
+  constraint 'a = 'b
+  method f = self
+end;;
+new c;;
+(* class 'a c ('a) :'b = constraint 'a = 'a c method f : 'a end *)
+(* - : ('a c as 'a) -> 'b c as 'b = <fun> *)
+
+class x () =
+  virtual f : int
+end;;
+(* The class x should be virtual:  its methods f is undefined *)
+
+(* Methode g en trop *)
+class virtual closed c ((x : 'a): < f : int >) : 'a =
+and virtual closed d x : 'a =
+  inherit c x
+  method g = true
+end;;
+
+(* Contrainte non respectee *)
+class 'a c () =
+  constraint 'a = int
+  method f x = (x : bool c)
+end;;
+
+(* Differentes contraintes *)
+class ('a, 'b) c () =
+  constraint 'a = int -> 'c
+  constraint 'b = 'a * <x : 'b> * 'c * 'd
+  method f (x : 'a) (y : 'b) = ()
+end;;
+class ('a, 'b) d () =
+  inherit ('a, 'b) c ()
+end;;
+
+(* Contrainte non generique *)
+let x = ref [];;
+class 'a c () =
+  method f = (x : 'a)
+end;;
+
+(* Abreviations *)
+type 'a c = <f : 'a c; g : 'a d>
+and 'a d = <f : int c>;;
+type 'a c = <f : 'a c; g : 'a d>
+and 'a d = <f : 'a c>;;
+type 'a c = <f : 'a c>
+and 'a d = <f : int c>;;
+type 'a u = < x : 'a>
+and 'a t = 'a t u;;
+type 'a u = 'a
+and 'a t = 'a t u;;
+type 'a u = 'a;;
+type t = t u * t u;;
+
+type t = <x : 'a> as 'a;;
+type 'a u = 'a;;
+fun (x : t) (y : 'a u) -> x = y;;
+fun (x : t) (y : 'a u) -> y = x;;
+(* - : t -> t u -> bool = <fun> *)
+
+(* Modules *)
+module M =
+  struct
+    class ('a, 'b) c x (y: 'b) =
+      constraint 'a = int -> bool
+      val x = []
+      val y = y
+      method f (x : 'a) = ()
+      method g = y
+    end
+  end;;
+module M' = (M :
+  sig
+     class virtual ('a, 'b) c (int) ('b) =
+       constraint 'a = int -> bool
+       val x : float list
+       val y : 'b
+       method f : 'a -> unit
+       method g : 'b
+     end
+   end);;
+class ('a, 'b) d () y = inherit ('a, 'b) M.c () y end;;
+class ('a, 'b) e () y = inherit ('a, 'b) M'.c 1 y end;;
+(new M.c () "a")#g;;
+(new M'.c 1)#g;;
+(new d () 10)#g;;
+(new e () 7.1)#g;;
+open M;;
+(new c () true)#g;;
+
+(* #cl quand cl est fermee *)
+module M = struct class closed 'a c () = method f (x : 'a) = () end end;;
+module M' =
+  (M : sig class closed 'a c (unit) = method f : 'a -> unit end end);;
+fun x -> (x :> 'a #M.c);;
+fun x -> (x :> 'a #M'.c);;
+class 'a c (x : 'b #c) = end;;
+class closed 'a c (x : 'b #c) = end;;
+
+(* Ordre de calcul *)
+class c () = method f = 1 and d () = method f = 2 end;;
+class e () = inherit c () inherit d () end;;
+(new e ())#f;;
+class c () = val x = - true val y = -. () end;;
+
+class c () = method f = 1 method g = 1 method h = 1 end;;
+class d () = method h = 2 method i = 2 method j = 2 end;;
+class e () =
+  method f = 3
+  inherit c ()
+  method g = 3
+  method i = 3
+  inherit d ()
+  method j = 3
+end;;
+let e = new e ();;
+e#f, e#g, e#h, e#i, e#j;;
+
+class c a = val x = 1 val y = 1 val z = 1 val a = a end;;
+class d b = val z = 2 val t = 2 val u = 2 val b = b end;;
+class e () =
+  val x = 3
+  inherit c 5
+  val y = 3
+  val t = 3
+  inherit d 7
+  val u = 3
+  method x = x
+  method y = y
+  method z = z
+  method t = t
+  method u = u
+  method a = a
+  method b = b
+end;;
+let e = new e ();;
+e#x, e#y, e#z, e#t, e#u, e#a, e#b;;
+
+class c (x : int) (y : int) =
+  val x = x
+  val y = y
+  method x = x
+  method y = y
+end;;
+class d x y = inherit c x y end;;
+let c = new c 1 2 in c#x, c#y;;
+let d = new d 1 2 in d#x, d#y;;
+
+(* Parametres n'apparaissant pas dans le type de l'objet *)
+class 'a c (x : 'a) = end;;
+new c;;
+
+(* Variables privees *)
+module type M = sig
+  class c (unit) = val x : int end
+  class d (unit) = inherit c val private x : int val x : bool end
+end;;
+class c (x : int) =
+  val private mutable x = x
+  method get = x
+  method set y = x <- y
+end;;
+let c = new c 5;;
+c#get;;
+c#set 7; c#get;;
+
+class c () = val x = 1 val y = 1 method c = x end;;
+class d () = inherit c () val private x method d = x end;;
+class e () =
+  val x = 2 val y = 2 inherit d () method x = x method y = y
+end;;
+let e = new e () in e#x, e#y, e#c, e#d;;
+
+(* Oubli de variables dans l'interface *)
+module M :
+  sig
+    class c (unit) =
+      method xc : int
+    end
+  end =
+  struct
+    class c () =
+      val x = 1
+      method xc = x
+    end
+  end;;
+class d () =
+  val x = 2
+  method xd = x
+  inherit M.c ()
+end;;
+let d = new d () in d#xc, d#xd;;
+
+class virtual 'a matrix (sz, init : int * 'a) =
+  val m = Array.create_matrix sz sz init
+  method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
+end;;
+
+class c () = method m = new c () end;;
+(new c ())#m;;
+module M = struct class c () = method m = new c () end end;;
+(new M.c ())#m;;
+
+type uu = A of int | B of (<leq: 'a> as 'a);;
+
+class virtual c () : 'a = virtual m : 'a end;;
+module S = (struct
+  let f (x : #c) = x
+end : sig
+  val f : #c as 'a -> 'a
+end);;
+module S = (struct
+  let f (x : #c) = x
+end : sig
+  val f : #c -> #c
+end);;
+
+module M = struct type t = int class t () = end end;;
+
+fun x -> (x :> < m : 'a -> 'a > as 'a);;
+
+fun x -> (x : int -> bool :> 'a -> 'a);;
+fun x -> (x : int -> bool :> int -> int);;
+fun x -> (x : < > :> < .. >);;
+fun x -> (x : < .. > :> < >);;
+
+let x = ref [];;
+module F(X : sig end) =
+  struct type t = int let _ = (x : < m : t> list ref) end;;
+x;;
+
+type 'a t;;
+fun (x : 'a t as 'a) -> ();;
+fun (x : 'a t) -> (x : 'a); ();;
+type 'a t = < x : 'a >;;
+fun (x : 'a t as 'a) -> ();;
+fun (x : 'a t) -> (x : 'a); ();;
+
+class 'a c () =
+  constraint 'a = < .. > -> unit
+  method m = (fun x -> () : 'a)
+end;;
+class 'a c () =
+  constraint 'a = unit -> < .. >
+  method m (f : 'a) = f ()
+end;;
+
+class c () as self =
+  private method m = 1
+  method n = self#m
+end;;
+
+class d () as self =
+  inherit c ()
+  method o = self#m
+end;;
+
+let x = new d () in x#n, x#o;;
+
+class c () = virtual m : int private method m = 1 end;;
diff --git a/tools/Makefile b/tools/Makefile
index 9d8a427c..04a6f0dc 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -10,7 +10,7 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile,v 1.55 2003/04/02 01:17:58 doligez Exp $
+# $Id: Makefile,v 1.59 2004/06/20 15:26:06 xleroy Exp $
 
 include ../config/Makefile
 
@@ -23,7 +23,7 @@ INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
 COMPFLAGS= -warn-error A $(INCLUDES)
 LINKFLAGS=$(INCLUDES)
 
-all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib scrapelabels addlabels
+all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib scrapelabels addlabels 
 
 opt.opt: ocamldep.opt
 
@@ -97,6 +97,7 @@ clean::
 	rm -f ocamlmklib
 
 ocamlmklib.ml: ocamlmklib.mlp ../config/Makefile
+	echo '(* THIS FILE IS GENERATED FROM ocamlmklib.mlp *)' >ocamlmklib.ml
 	sed -e "s|%%BINDIR%%|$(BINDIR)|" \
             -e "s|%%SUPPORTS_SHARED_LIBRARIES%%|$(SUPPORTS_SHARED_LIBRARIES)|" \
             -e "s|%%MKSHAREDLIB%%|$(MKSHAREDLIB)|" \
@@ -104,7 +105,7 @@ ocamlmklib.ml: ocamlmklib.mlp ../config/Makefile
             -e "s|%%NATIVECCRPATH%%|$(NATIVECCRPATH)|" \
             -e "s|%%MKSHAREDLIBRPATH%%|$(MKSHAREDLIBRPATH)|" \
             -e "s|%%RANLIB%%|$(RANLIB)|" \
-          ocamlmklib.mlp > ocamlmklib.ml
+          ocamlmklib.mlp >> ocamlmklib.ml
 
 beforedepend:: ocamlmklib.ml
 
@@ -223,14 +224,6 @@ objinfo: objinfo.cmo
 clean::
 	rm -f objinfo
 
-# Print imported interfaces for .cmi files
-
-intfinfo: intfinfo.cmo
-	$(CAMLC) $(LINKFLAGS) -o intfinfo config.cmo intfinfo.cmo
-
-clean::
-	rm -f intfinfo
-
 # Scan object files for required primitives
 
 PRIMREQ=primreq.cmo
diff --git a/tools/Makefile.Mac b/tools/Makefile.Mac
deleted file mode 100644
index 6d34efc8..00000000
--- a/tools/Makefile.Mac
+++ /dev/null
@@ -1,137 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#            Damien Doligez, projet Para, INRIA Rocquencourt            #
-#                                                                       #
-#   Copyright 1999 Institut National de Recherche en Informatique et    #
-#   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the Q Public License version 1.0.                #
-#                                                                       #
-#########################################################################
-
-# $Id: Makefile.Mac,v 1.21 2002/04/18 07:27:43 garrigue Exp $
-
-CAMLRUN = ::boot:ocamlrun
-CAMLC = "{CAMLRUN}" ::boot:ocamlc -I ::boot:
-CAMLLEX = "{CAMLRUN}" ::boot:ocamllex
-INCLUDES = -I ::utils: -I ::parsing: -I ::typing: -I ::bytecomp: -I ::asmcomp:
-COMPFLAGS = {INCLUDES}
-LINKFLAGS = {INCLUDES}
-
-all Ä ocamldep ocamldumpobj objinfo primreq keywords
-
-# The dependency generator
-
-CAMLDEP_IMPORTS = misc.cmo config.cmo clflags.cmo terminfo.cmo ¶
-   linenum.cmo warnings.cmo location.cmo longident.cmo ¶
-   syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
-
-CAMLDEP = depend.cmo ocamldep.cmo
-
-ocamldep Ä depend.cmi {CAMLDEP}
-    {CAMLC} {LINKFLAGS} -o ocamldep {CAMLDEP_IMPORTS} {CAMLDEP}
-
-clean ÄÄ
-    delete -i ocamldep
-
-install ÄÄ
-    duplicate -y ocamldep "{BINDIR}ocamldep"
-
-# The profiler  (not available on MacOS for the moment)
-#
-#CSLPROF = ocamlprof.cmo
-#CSLPROF_IMPORTS = misc.cmo config.cmo clflags.cmo terminfo.cmo ¶
-#  linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo ¶
-#  syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
-#
-#ocamlprof Ä {CSLPROF} profiling.cmo
-#   {CAMLC} {LINKFLAGS} -o ocamlprof {CSLPROF_IMPORTS} {CSLPROF}
-#
-#install ÄÄ
-#   duplicate -y ocamlprof "{BINDIR}ocamlprof"
-#   duplicate -y ocamlcp "{BINDIR}ocamlcp"
-#   duplicate -y profiling.cmi profiling.cmo "{LIBDIR}"
-#
-#clean ÄÄ
-#   delete -i ocamlprof
-
-# To make custom toplevels
-
-install ÄÄ
-    duplicate -y ocamlmktop.tpl "{BINDIR}ocamlmktop"
-
-# The bytecode disassembler
-
-DUMPOBJ = opnames.cmo dumpobj.cmo
-
-ocamldumpobj Ä {DUMPOBJ}
-    {CAMLC} {LINKFLAGS} -o ocamldumpobj ¶
-            misc.cmo tbl.cmo config.cmo ident.cmo opcodes.cmo ¶
-            bytesections.cmo {DUMPOBJ}
-
-clean ÄÄ
-    delete -i ocamldumpobj
-
-install ÄÄ
-    duplicate -y ocamldumpobj "{BINDIR}ocamldumpobj"
-
-opnames.ml Ä ::byterun:instruct.h
-    streamedit -e '/¶/¶*/ delete' ¶
-           -e '/enum (Å)¨0 {/ replace // "let names_of_" ¨0 "= [|"' ¶
-           -e '/};°/ replace // "|]"' ¶
-           -e '/([A-Z][A-Z_0-9a-z]*)¨0/ replace // "¶"" ¨0 "¶"" -c °' ¶
-           -e '/,/ replace // ";" -c °' ¶
-           ::byterun:instruct.h > opnames.ml
-
-clean ÄÄ
-    delete -i opnames.ml
-
-beforedepend ÄÄ opnames.ml
-
-# Dump .cmx files
-
-#dumpapprox Ä dumpapprox.cmo
-#    {CAMLC} {LINKFLAGS} -o dumpapprox config.cmo dumpapprox.cmo
-#
-#clean ÄÄ
-#    delete -i dumpapprox
-
-# Print imported interfaces for .cmo files
-
-objinfo Ä objinfo.cmo
-    {CAMLC} {LINKFLAGS} -o objinfo config.cmo objinfo.cmo
-
-clean ÄÄ
-    delete -i objinfo
-
-# Common stuff
-
-.cmo Ä .ml
-    {CAMLC} -c {COMPFLAGS} {depdir}{default}.ml
-
-.cmi Ä .mli
-    {CAMLC} -c {COMPFLAGS} {depdir}{default}.mli
-
-clean ÄÄ
-    delete -i Å.cm[io] || set status 0
-
-depend Ä beforedepend
-    {CAMLRUN} :ocamldep {INCLUDES} Å.mli Å.ml > Makefile.Mac.depend
-
-# Scan object files for required primitives
-
-primreq Ä primreq.cmo
-    {CAMLC} {LINKFLAGS} -o primreq config.cmo primreq.cmo
- 
-clean ÄÄ
-    delete -i primreq
-
-
-# Resources for keyword-coloring for MPW Shell
-
-keywords Ä keywords.r
-    rez -t rsrc -c RSED -o keywords keywords.r
-
-clean ÄÄ
-    delete -i keywords
diff --git a/tools/Makefile.Mac.depend b/tools/Makefile.Mac.depend
deleted file mode 100644
index 0393c706..00000000
--- a/tools/Makefile.Mac.depend
+++ /dev/null
@@ -1,30 +0,0 @@
-dumpapprox.cmoÄ ::asmcomp:clambda.cmi ::asmcomp:compilenv.cmi ¶
-    ::utils:config.cmi 
-dumpapprox.cmxÄ ::asmcomp:clambda.cmx ::asmcomp:compilenv.cmx ¶
-    ::utils:config.cmx 
-dumpobj.cmoÄ ::parsing:asttypes.cmi ::bytecomp:bytesections.cmi ¶
-    ::utils:config.cmi ::bytecomp:emitcode.cmi ::typing:ident.cmi ¶
-    ::bytecomp:instruct.cmi ::bytecomp:lambda.cmi ::bytecomp:opcodes.cmo ¶
-    opnames.cmo ::utils:tbl.cmi 
-dumpobj.cmxÄ ::parsing:asttypes.cmi ::bytecomp:bytesections.cmx ¶
-    ::utils:config.cmx ::bytecomp:emitcode.cmx ::typing:ident.cmx ¶
-    ::bytecomp:instruct.cmx ::bytecomp:lambda.cmx ::bytecomp:opcodes.cmx ¶
-    opnames.cmx ::utils:tbl.cmx 
-objinfo.cmoÄ ::utils:config.cmi ::bytecomp:emitcode.cmi 
-objinfo.cmxÄ ::utils:config.cmx ::bytecomp:emitcode.cmx 
-ocamldep.cmoÄ ::utils:clflags.cmo ::utils:config.cmi ::parsing:lexer.cmi ¶
-    ::parsing:location.cmi ::parsing:longident.cmi ::utils:misc.cmi ¶
-    ::parsing:parse.cmi ::parsing:parsetree.cmi ::parsing:syntaxerr.cmi 
-ocamldep.cmxÄ ::utils:clflags.cmx ::utils:config.cmx ::parsing:lexer.cmx ¶
-    ::parsing:location.cmx ::parsing:longident.cmx ::utils:misc.cmx ¶
-    ::parsing:parse.cmx ::parsing:parsetree.cmi ::parsing:syntaxerr.cmx 
-ocamlprof.cmoÄ ::utils:clflags.cmo ::utils:config.cmi ::parsing:lexer.cmi ¶
-    ::parsing:location.cmi ::utils:misc.cmi ::parsing:parse.cmi ¶
-    ::parsing:parsetree.cmi ::parsing:syntaxerr.cmi 
-ocamlprof.cmxÄ ::utils:clflags.cmx ::utils:config.cmx ::parsing:lexer.cmx ¶
-    ::parsing:location.cmx ::utils:misc.cmx ::parsing:parse.cmx ¶
-    ::parsing:parsetree.cmi ::parsing:syntaxerr.cmx 
-primreq.cmoÄ ::utils:config.cmi ::bytecomp:emitcode.cmi 
-primreq.cmxÄ ::utils:config.cmx ::bytecomp:emitcode.cmx 
-profiling.cmoÄ profiling.cmi 
-profiling.cmxÄ profiling.cmi 
diff --git a/tools/addlabels.ml b/tools/addlabels.ml
index aeb55040..4f765e37 100644
--- a/tools/addlabels.ml
+++ b/tools/addlabels.ml
@@ -1,4 +1,4 @@
-(* $Id: addlabels.ml,v 1.9 2002/11/01 17:06:47 doligez Exp $ *)
+(* $Id: addlabels.ml,v 1.10 2003/11/25 09:20:45 garrigue Exp $ *)
 
 open StdLabels
 open Asttypes
@@ -276,7 +276,7 @@ let rec add_labels_expr ~text ~values ~classes expr =
   | Pexp_override lst ->
       List.iter lst ~f:(fun (_,e) -> add_labels_rec e)
   | Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _
-  | Pexp_new _ | Pexp_assertfalse ->
+  | Pexp_new _ | Pexp_assertfalse | Pexp_object _ ->
       ()
 
 let rec add_labels_class ~text ~classes ~values ~methods cl =
diff --git a/tools/depend.ml b/tools/depend.ml
index 09d7e8e5..08db07b6 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: depend.ml,v 1.6 2003/07/02 09:14:31 xleroy Exp $ *)
+(* $Id: depend.ml,v 1.7 2003/11/25 09:20:45 garrigue Exp $ *)
 
 open Format
 open Location
@@ -154,7 +154,8 @@ let rec add_expr bv exp =
   | Pexp_assertfalse -> ()
   | Pexp_lazy (e) -> add_expr bv e
   | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
-
+  | Pexp_object (pat, fieldl) ->
+      add_pattern bv pat; List.iter (add_class_field bv) fieldl
 and add_pat_expr_list bv pel =
   List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
 
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 5e263e6d..18598a65 100644
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: dumpobj.ml,v 1.31 2003/04/25 12:27:31 xleroy Exp $ *)
+(* $Id: dumpobj.ml,v 1.34 2004/05/26 11:10:52 garrigue Exp $ *)
 
 (* Disassembler for executable and .cmo object files *)
 
@@ -108,12 +108,12 @@ let rec print_struct_const = function
 
 let rec print_obj x =
   if Obj.is_block x then begin
-    match Obj.tag x with
-      252 ->                            (* string *)
+    let tag = Obj.tag x in
+    if tag = Obj.string_tag then
         printf "%S" (Obj.magic x : string)
-    | 253 ->                            (* float *)
+    else if tag = Obj.double_tag then
         printf "%.12g" (Obj.magic x : float)
-    | 254 ->                            (* float array *)
+    else if tag = Obj.double_array_tag then begin
         let a = (Obj.magic x : float array) in
         printf "[|";
         for i = 0 to Array.length a - 1 do
@@ -121,9 +121,9 @@ let rec print_obj x =
           printf "%.12g" a.(i)
         done;
         printf "|]"
-    | _ ->
+    end else if tag < Obj.no_scan_tag then begin
         printf "<%d>" (Obj.tag x);
-        begin match Obj.size x with
+        match Obj.size x with
           0 -> ()
         | 1 ->
             printf "("; print_obj (Obj.field x 0); printf ")"
@@ -133,7 +133,8 @@ let rec print_obj x =
               printf ", "; print_obj (Obj.field x i)
             done;
             printf ")"
-        end
+    end else
+        printf "<tag %d>" tag
   end else
     printf "%d" (Obj.magic x : int)
 
@@ -233,6 +234,7 @@ type shape =
   | Uint_Primitive
   | Switch
   | Closurerec
+  | Pubmet
 ;;
 
 let op_shapes = [
@@ -367,6 +369,8 @@ let op_shapes = [
   opOFFSETREF, Sint;
   opISINT, Nothing;
   opGETMETHOD, Nothing;
+  opGETDYNMET, Nothing;
+  opGETPUBMET, Pubmet;
   opBEQ, Sint_Disp;
   opBNEQ, Sint_Disp;
   opBLTINT, Sint_Disp;
@@ -435,6 +439,10 @@ let print_instr ic =
           print_string ", ";
           print_int (orig + inputu ic);
         done;
+  | Pubmet
+     -> let tag = inputs ic in
+        let cache = inputu ic in
+	print_int tag
   | Nothing -> ()
   with Not_found -> print_string "(unknown arguments)"
   end;
@@ -521,13 +529,17 @@ let dump_exe ic =
 
 let main() =
   for i = 1 to Array.length Sys.argv - 1 do
-    let ic = open_in_bin Sys.argv.(i) in
+    let filnam = Sys.argv.(i) in
+    let ic = open_in_bin filnam in
+    if i>1 then print_newline ();
+    printf "## start of ocaml dump of %S\n%!" filnam;
     begin try
       objfile := false; dump_exe ic
     with Bytesections.Bad_magic_number ->
       objfile := true; seek_in ic 0; dump_obj (Sys.argv.(i)) ic
     end;
-    close_in ic
+    close_in ic;
+    printf "## end of ocaml dump of %S\n%!" filnam;
   done;
   exit 0
 
diff --git a/tools/lexer299.mll b/tools/lexer299.mll
index 3e45d1e8..3e1c3cf3 100644
--- a/tools/lexer299.mll
+++ b/tools/lexer299.mll
@@ -10,11 +10,12 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer299.mll,v 1.1 2000/04/12 09:50:55 garrigue Exp $ *)
+(* $Id: lexer299.mll,v 1.3 2004/03/10 08:56:01 garrigue Exp $ *)
 
 (* The lexer definition *)
 
 {
+open Lexing
 open Misc
 
 type token =
@@ -219,25 +220,12 @@ let get_stored_string () =
 
 (* To translate escape sequences *)
 
-let char_for_backslash =
-  match Sys.os_type with
-  | "Unix" | "Win32" ->
-      begin function
-      | 'n' -> '\010'
-      | 'r' -> '\013'
-      | 'b' -> '\008'
-      | 't' -> '\009'
-      | c   -> c
-      end
-  | "MacOS" ->
-      begin function
-      | 'n' -> '\013'
-      | 'r' -> '\010'
-      | 'b' -> '\008'
-      | 't' -> '\009'
-      | c   -> c
-      end
-  | x -> fatal_error "Lexer: unknown system type"
+let char_for_backslash = function
+  | 'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
 
 let char_for_decimal_code lexbuf i =
   let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
@@ -290,7 +278,9 @@ rule token = parse
       { UNDERSCORE }
   | lowercase identchar * ':' [ ^ ':' '=' '>']
       { let s = Lexing.lexeme lexbuf in
-        lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
+        lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 1;
+        lexbuf.lex_curr_p <-
+          {lexbuf.lex_curr_p with pos_cnum = lexbuf.lex_curr_p.pos_cnum - 1};
         LABEL (String.sub s 0 (String.length s - 2)) }
 (*
   | lowercase identchar * ':'
@@ -333,8 +323,8 @@ rule token = parse
         comment lexbuf;
         token lexbuf }
   | "(*)"
-      { let loc = { Location.loc_start = Lexing.lexeme_start lexbuf;
-                    Location.loc_end = Lexing.lexeme_end lexbuf - 1;
+      { let loc = { Location.loc_start = Lexing.lexeme_start_p lexbuf;
+                    Location.loc_end = Lexing.lexeme_end_p lexbuf;
                     Location.loc_ghost = false }
         and warn = Warnings.Comment "the start of a comment"
         in
@@ -344,8 +334,8 @@ rule token = parse
         token lexbuf
       }
   | "*)"
-      { let loc = { Location.loc_start = Lexing.lexeme_start lexbuf;
-                    Location.loc_end = Lexing.lexeme_end lexbuf;
+      { let loc = { Location.loc_start = Lexing.lexeme_start_p lexbuf;
+                    Location.loc_end = Lexing.lexeme_end_p lexbuf;
                     Location.loc_ghost = false }
         and warn = Warnings.Comment "not the end of a comment"
         in
diff --git a/tools/lexer301.mll b/tools/lexer301.mll
index 639816b5..a25cd0da 100644
--- a/tools/lexer301.mll
+++ b/tools/lexer301.mll
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer301.mll,v 1.3 2002/11/01 17:06:47 doligez Exp $ *)
+(* $Id: lexer301.mll,v 1.4 2004/01/16 15:24:03 doligez Exp $ *)
 
 (* The lexer definition *)
 
@@ -223,25 +223,12 @@ let get_stored_string () =
 
 (* To translate escape sequences *)
 
-let char_for_backslash =
-  match Sys.os_type with
-  | "Unix" | "Win32" | "Cygwin" ->
-      begin function
-      | 'n' -> '\010'
-      | 'r' -> '\013'
-      | 'b' -> '\008'
-      | 't' -> '\009'
-      | c   -> c
-      end
-  | "MacOS" ->
-      begin function
-      | 'n' -> '\013'
-      | 'r' -> '\010'
-      | 'b' -> '\008'
-      | 't' -> '\009'
-      | c   -> c
-      end
-  | x -> fatal_error "Lexer: unknown system type"
+let char_for_backslash = function
+  | 'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
 
 let char_for_decimal_code lexbuf i =
   let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
diff --git a/tools/make-opcodes.Mac b/tools/make-opcodes.Mac
deleted file mode 100644
index 0d138229..00000000
--- a/tools/make-opcodes.Mac
+++ /dev/null
@@ -1,14 +0,0 @@
-set echo 0
-exit 1 if {#} != 2
-
-catenate "{1}" >"{2}"
-open -t "{2}"
-replace ¥:/¥  / 'let op' "{2}"
-set i 0
-loop
-  replace /,[ ¶n]+/ " = {i}¶nlet op" "{2}" || break
-  evaluate i += 1
-end
-replace /¥[Â ]/:° " = {i}¶n" "{2}"
-
-close -y "{2}"
diff --git a/tools/make-package-macosx b/tools/make-package-macosx
index 3bf4a39a..41ab8fd5 100755
--- a/tools/make-package-macosx
+++ b/tools/make-package-macosx
@@ -12,24 +12,104 @@
 #                                                                       #
 #########################################################################
 
-# $Id: make-package-macosx,v 1.4 2003/03/27 16:28:12 doligez Exp $
+# $Id: make-package-macosx,v 1.8 2004/04/29 12:16:58 doligez Exp $
 
 cd package-macosx
-rm -rf ocaml.pkg ocaml-rw.dmg ocaml.dmg
-
-cat >ocaml.info <<EOF
-  Title Objective Caml
-  Version 3.06
-  Description This package installs Objective Caml version 3.06
-  DefaultLocation /
-  Relocatable no
-  NeedsAuthorization yes
-  Application no
-  InstallOnly no
-  DisableStop no
+rm -rf ocaml.pkg ocaml-rw.dmg
+
+VERSION=`sed -n -e '/ocaml_version/s/.*"\([^"]*\)".*/\1/p' ../stdlib/sys.ml`
+VERSION_MAJOR=`sed -n -e '/ocaml_version/s/.*"\([0-9]*\)\..*/\1/p' \
+                   ../stdlib/sys.ml`
+VERSION_MINOR=`sed -n -e '/ocaml_version/s/.*"[0-9]*\.\([0-9]*\)[.+].*/\1/p' \
+                   ../stdlib/sys.ml`
+
+# Worked in 10.2:
+
+# cat >ocaml.info <<EOF
+#   Title Objective Caml
+#   Version ${VERSION}
+#   Description This package installs Objective Caml version ${VERSION}
+#   DefaultLocation /
+#   Relocatable no
+#   NeedsAuthorization yes
+#   Application no
+#   InstallOnly no
+#   DisableStop no
+# EOF
+#package root ocaml.info
+
+cat >Description.plist <<EOF
+  <?xml version="1.0" encoding="UTF-8"?>
+  <!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN"
+            "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+  <plist version="1.0">
+  <dict>
+          <key>IFPkgDescriptionDeleteWarning</key>
+          <string></string>
+          <key>IFPkgDescriptionDescription</key>
+          <string>The Objective Caml compiler and tools</string>
+          <key>IFPkgDescriptionTitle</key>
+          <string>Objective Caml</string>
+          <key>IFPkgDescriptionVersion</key>
+          <string>${VERSION}</string>
+  </dict>
+  </plist>
+EOF
+
+cat >Info.plist <<EOF
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN"
+          "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+        <key>CFBundleGetInfoString</key>
+        <string>Objective Caml ${VERSION}</string>
+        <key>CFBundleIdentifier</key>
+        <string>fr.inria.ocaml</string>
+        <key>CFBundleName</key>
+        <string>Objective Caml</string>
+        <key>CFBundleShortVersionString</key>
+        <string>${VERSION}</string>
+        <key>IFMajorVersion</key>
+        <integer>${VERSION_MAJOR}</integer>
+        <key>IFMinorVersion</key>
+        <integer>${VERSION_MINOR}</integer>
+        <key>IFPkgFlagAllowBackRev</key>
+        <true/>
+        <key>IFPkgFlagAuthorizationAction</key>
+        <string>AdminAuthorization</string>
+        <key>IFPkgFlagDefaultLocation</key>
+        <string>/</string>
+        <key>IFPkgFlagInstallFat</key>
+        <false/>
+        <key>IFPkgFlagIsRequired</key>
+        <false/>
+        <key>IFPkgFlagRelocatable</key>
+        <false/>
+        <key>IFPkgFlagRestartAction</key>
+        <string>NoRestart</string>
+        <key>IFPkgFlagRootVolumeOnly</key>
+        <true/>
+        <key>IFPkgFlagUpdateInstalledLanguages</key>
+        <false/>
+        <key>IFPkgFormatVersion</key>
+        <real>0.10000000149011612</real>
+</dict>
+</plist>
+EOF
+
+mkdir -p resources
+
+#                                         stop here -> |
+cat >resources/ReadMe.txt <<EOF
+This package installs Objective Caml version ${VERSION}.
+You need Mac OS X 10.3 (panther), with X11 and the
+XCode tools installed.
 EOF
 
-package root ocaml.info
+/Developer/Applications/Utilities/PackageMaker.app/Contents/MacOS/PackageMaker \
+  -build -p "`pwd`/ocaml.pkg" -f "`pwd`/root" -i "`pwd`/Info.plist" \
+  -d "`pwd`/Description.plist" -r "`pwd`/resources"
 
 size=`du -s ocaml.pkg | cut -f 1`
 size=`expr $size + 8192`
@@ -42,6 +122,7 @@ hdiutil detach $name
 name=`hdid ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1`
 if test -d '/Volumes/Objective Caml'; then
   ditto -rsrcFork ocaml.pkg "/Volumes/Objective Caml/ocaml.pkg"
+  cp resources/ReadMe.txt "/Volumes/Objective Caml/"
 else
   echo 'Unable to mount the disk image as "/Volumes/Objective Caml"' >&2
   exit 3
@@ -49,4 +130,5 @@ fi
 open "/Volumes/Objective Caml"
 hdiutil detach $name
 
-hdiutil convert ocaml-rw.dmg -format UDZO -o ocaml.dmg
+rm -rf "ocaml-${VERSION}.dmg"
+hdiutil convert ocaml-rw.dmg -format UDZO -o "ocaml${VERSION}.dmg"
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index 5b885d31..4edbe0f7 100644
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ocamldep.ml,v 1.32 2003/04/06 12:41:54 doligez Exp $ *)
+(* $Id: ocamldep.ml,v 1.33 2004/01/16 15:24:03 doligez Exp $ *)
 
 open Format
 open Location
@@ -73,11 +73,7 @@ let find_dependency modname (byt_deps, opt_deps) =
   with Not_found ->
     (byt_deps, opt_deps)
 
-let (depends_on, escaped_eol) =
-  match Sys.os_type with
-  | "Unix" | "Win32" | "Cygwin" -> (": ", "\\\n    ")
-  | "MacOS" -> ("\196 ", "\182\n    ")
-  | _ -> assert false
+let (depends_on, escaped_eol) = (": ", "\\\n    ")
 
 let print_dependencies target_file deps =
   match deps with
diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp
index 27eecccb..734355d1 100644
--- a/tools/ocamlmklib.mlp
+++ b/tools/ocamlmklib.mlp
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id$ *)
+(* $Id: ocamlmklib.mlp,v 1.10.2.1 2004/07/08 06:45:51 garrigue Exp $ *)
 
 open Printf
 
@@ -143,7 +143,7 @@ Options are:
   -ocamlc <cmd>  Use <cmd> in place of \"ocamlc\"
   -ocamlopt <cmd> Use <cmd> in place of \"ocamlopt\"
   -o <name>      Generated Caml library is named <name>.cma or <name>.cmxa
-  -oc <name>     Generated C library is named lib<name>.so or lib<name>.a
+  -oc <name>     Generated C library is named dll<name>.so or lib<name>.a
   -rpath <dir>   Same as -dllpath <dir>
   -R<dir>        Same as -rpath
   -verbose       Print commands before executing them
@@ -184,13 +184,19 @@ let make_rpath_ccopt flag =
 let prefix_list pref l =
   List.map (fun s -> pref ^ s) l
 
+let prepostfix pre name post =
+  let base = Filename.basename name in
+  let dir = Filename.dirname name in
+  Filename.concat dir (pre ^ base ^ post)
+;;
+
 let build_libs () =
   if !c_objs <> [] then begin
     if !dynlink then begin
       let retcode = command
-        (sprintf "%s dll%s.so %s %s %s %s %s"
+        (sprintf "%s %s %s %s %s %s %s"
                     mksharedlib
-                    !output_c
+                    (prepostfix "dll" !output_c ".so")
                     (String.concat " " !c_objs)
                     (String.concat " " !c_opts)
                     (String.concat " " !ld_opts)
@@ -198,15 +204,15 @@ let build_libs () =
                     (String.concat " " !c_libs)) in
       if retcode <> 0 then if !failsafe then dynlink := false else exit 2
     end;
-    safe_remove ("lib" ^ !output_c ^ ".a");
+    safe_remove (prepostfix "lib" !output_c ".a");
     scommand
-      (sprintf "ar rc lib%s.a %s"
-                  !output_c
+      (sprintf "ar rc %s %s"
+                  (prepostfix "lib" !output_c ".a")
                   (String.concat " " !c_objs));
     scommand
-      (sprintf "%s lib%s.a"
+      (sprintf "%s %s"
                   ranlib
-                  !output_c)
+                  (prepostfix "lib" !output_c ".a"))
   end;
   if !bytecode_objs <> [] then
     scommand
diff --git a/tools/ocamlmktop.tpl b/tools/ocamlmktop.tpl
index 6cc7d851..9ee3529b 100644
--- a/tools/ocamlmktop.tpl
+++ b/tools/ocamlmktop.tpl
@@ -11,16 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: ocamlmktop.tpl,v 1.4 2002/04/24 09:40:19 xleroy Exp $
+# $Id: ocamlmktop.tpl,v 1.5 2004/02/22 14:52:50 xleroy Exp $
 
-
-# Multi-shell script.  Works under Bourne Shell, MPW Shell, zsh.
-
-if : == x
-then # Bourne Shell or zsh
-     exec %%BINDIR%%/ocamlc -linkall toplevellib.cma "$@" topstart.cmo
-else # MPW Shell
-     ocamlc -linkall toplevellib.cma {"parameters"} topstart.cmo
-     exit {status}
-End # uppercase E because "end" is a keyword in zsh
-fi
+exec %%BINDIR%%/ocamlc -linkall toplevellib.cma "$@" topstart.cmo
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 1541efde..ac34700a 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ocamlprof.ml,v 1.32 2002/11/04 10:49:35 doligez Exp $ *)
+(* $Id: ocamlprof.ml,v 1.37 2004/06/16 16:58:46 doligez Exp $ *)
 
 open Printf
 
@@ -21,8 +21,9 @@ open Location
 open Misc
 open Parsetree
 
-(* User programs must not use identifiers that start with this prefix. *)
-let idprefix = "__ocaml_prof";;
+(* User programs must not use identifiers that start with these prefixes. *)
+let idprefix = "__ocaml_prof_";;
+let modprefix = "OCAML__prof_";;
 
 
 (* Errors specific to the profiler *)
@@ -87,8 +88,10 @@ let add_incr_counter modul (kind,pos) =
    | Close -> fprintf !outchan ")";
    | Open ->
          fprintf !outchan
-                 "(%s_cnt_%s_.(%d) <- Pervasives.succ %s_cnt_%s_.(%d); "
-                 idprefix modul !prof_counter idprefix modul !prof_counter;
+                 "(%sArray.set %s_cnt %d \
+                               (%sPervasives.succ (%sArray.get %s_cnt %d)); "
+                 modprefix idprefix !prof_counter
+                 modprefix modprefix idprefix !prof_counter;
          incr prof_counter;
 ;;
 
@@ -127,12 +130,14 @@ let pos_len = ref 0
 let init_rewrite modes mod_name =
   cur_point := 0;
   if !instr_mode then begin
-    fprintf !outchan "let %s_cnt_%s_ = Array.create 0000000" idprefix mod_name;
+    fprintf !outchan "module %sArray = Array;; " modprefix;
+    fprintf !outchan "module %sPervasives = Pervasives;; " modprefix;
+    fprintf !outchan "let %s_cnt = Array.create 0000000" idprefix;
     pos_len := pos_out !outchan;
     fprintf !outchan 
             " 0;; Profiling.counters := \
-              (\"%s\", (\"%s\", %s_cnt_%s_)) :: !Profiling.counters;; "
-            mod_name modes idprefix mod_name
+              (\"%s\", (\"%s\", %s_cnt)) :: !Profiling.counters;; "
+            mod_name modes idprefix;
   end
 
 let final_rewrite add_function =
@@ -178,7 +183,7 @@ and rw_exp iflag sexp =
     rewrite_exp iflag sbody
 
   | Pexp_function (_, _, caselist) ->
-    if !instr_fun && not sexp.pexp_loc.loc_ghost then
+    if !instr_fun then
       rewrite_function iflag caselist
     else
       rewrite_patlexp_list iflag caselist
@@ -282,6 +287,9 @@ and rw_exp iflag sexp =
 
   | Pexp_poly (sexp, _) -> rewrite_exp iflag sexp
 
+  | Pexp_object (_, fieldl) ->
+      List.iter (rewrite_class_field iflag) fieldl
+
 and rewrite_ifbody iflag ghost sifbody =
   if !instr_if && not ghost then
     insert_profile rw_exp sifbody
@@ -408,6 +416,7 @@ let process_intf_file filename = null_rewrite filename;;
 
 let process_impl_file filename =
    let modname = Filename.basename(Filename.chop_extension filename) in
+       (* FIXME should let modname = String.capitalize modname *)
    if !instr_mode then begin
      (* Instrumentation mode *)
      set_flags !modes;
diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml
index fcf1e39f..a78c5555 100644
--- a/toplevel/expunge.ml
+++ b/toplevel/expunge.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: expunge.ml,v 1.15 2002/11/17 16:42:11 xleroy Exp $ *)
+(* $Id: expunge.ml,v 1.16 2004/01/16 15:24:03 doligez Exp $ *)
 
 (* "Expunge" a toplevel by removing compiler modules from the global List.map.
    Usage: expunge <source file> <dest file> <names of modules to keep> *)
@@ -47,11 +47,6 @@ let main () =
   Bytesections.read_toc ic;
   let toc = Bytesections.toc() in
   let pos_first_section = Bytesections.pos_first_section ic in
-  if Sys.os_type = "MacOS" then begin
-    (* Create output as a text file for bytecode scripts *)
-    let c = open_out_gen [Open_wronly; Open_creat] 0o777 output_name in
-    close_out c
-  end;
   let oc =
     open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777
                  output_name in
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 3ab7a50f..62dcaff8 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: genprintval.ml,v 1.36 2003/07/02 09:14:32 xleroy Exp $ *)
+(* $Id: genprintval.ml,v 1.37 2004/06/13 16:23:35 xleroy Exp $ *)
 
 (* To print values *)
 
@@ -354,9 +354,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
         tree_of_constr_with_args
            (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args
       with Not_found | EVP.Error ->
-        match check_depth depth obj ty with
+        match check_depth depth bucket ty with
           Some x -> x
-        | None -> outval_of_untyped_exception obj
+        | None -> outval_of_untyped_exception bucket
 
     in tree_of_val max_depth obj ty
 
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 78d33c88..2f395383 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: topdirs.ml,v 1.60 2002/11/18 13:49:44 xleroy Exp $ *)
+(* $Id: topdirs.ml,v 1.62.2.1 2004/06/23 12:10:02 garrigue Exp $ *)
 
 (* Toplevel directives *)
 
@@ -102,12 +102,16 @@ let load_file ppf name =
         let toc_pos = input_binary_int ic in  (* Go to table of contents *)
         seek_in ic toc_pos;
         let lib = (input_value ic : library) in
-        begin try
-          Dll.open_dlls (List.map Dll.extract_dll_name lib.lib_dllibs)
-        with Failure reason ->
-          fprintf ppf "Cannot load required shared library: %s.@." reason;
-          raise Load_failed
-        end;
+        List.iter
+          (fun dllib ->
+            let name = Dll.extract_dll_name dllib in
+            try Dll.open_dlls [name]
+            with Failure reason ->
+              fprintf ppf
+                "Cannot load required shared library %s.@.Reason: %s.@."
+                name reason;
+              raise Load_failed)
+          lib.lib_dllibs;
         List.iter (load_compunit ic filename ppf) lib.lib_units;
         true
       end else begin
@@ -198,7 +202,7 @@ let _ = Hashtbl.add directive_table "remove_printer"
 
 (* The trace *)
 
-external current_environment: unit -> Obj.t = "get_current_environment"
+external current_environment: unit -> Obj.t = "caml_get_current_environment"
 
 let tracing_function_ptr =
   get_code_pointer
@@ -249,7 +253,7 @@ let dir_untrace ppf lid =
         []
     | f :: rem ->
         if Path.same f.path path then begin
-          set_code_pointer (eval_path path) f.actual_code;
+          set_code_pointer f.closure f.actual_code;
           fprintf ppf "%a is no longer traced.@." Printtyp.longident lid;
           rem
         end else f :: remove rem in
@@ -260,7 +264,7 @@ let dir_untrace ppf lid =
 let dir_untrace_all ppf () =
   List.iter
     (fun f ->
-      set_code_pointer (eval_path f.path) f.actual_code;
+      set_code_pointer f.closure f.actual_code;
       fprintf ppf "%a is no longer traced.@." Printtyp.path f.path)
     !traced_functions;
   traced_functions := []
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index 23987a9c..fb905468 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: toploop.ml,v 1.83 2003/08/21 13:55:30 xleroy Exp $ *)
+(* $Id: toploop.ml,v 1.87 2004/06/12 08:55:47 xleroy Exp $ *)
 
 (* The interactive toplevel loop *)
 
@@ -52,7 +52,7 @@ let rec eval_path = function
       if Ident.persistent id || Ident.global id then
         Symtable.get_global_value id
       else begin
-        let name = Ident.name id in
+        let name = Translmod.toplevel_name id in
         try
           Hashtbl.find toplevel_value_bindings name
         with Not_found ->
@@ -132,11 +132,17 @@ let load_lambda ppf lam =
     may_trace := true;
     let retval = (Meta.reify_bytecode code code_size) () in
     may_trace := false;
-    if can_free then Meta.static_free code;
+    if can_free then begin 
+      Meta.static_release_bytecode code code_size;
+      Meta.static_free code;
+    end;
     Result retval
   with x ->
     may_trace := false;
-    if can_free then Meta.static_free code;
+    if can_free then begin 
+      Meta.static_release_bytecode code code_size;
+      Meta.static_free code;
+    end;
     Symtable.restore_state initial_symtable;
     Exception x
 
@@ -156,23 +162,23 @@ let pr_item env = function
             Some v
       in
       Some (tree, valopt, rem)
-  | Tsig_type(id, decl) :: rem ->
-      let tree = Printtyp.tree_of_type_declaration id decl in
+  | Tsig_type(id, decl, rs) :: rem ->
+      let tree = Printtyp.tree_of_type_declaration id decl rs in
       Some (tree, None, rem)
   | Tsig_exception(id, decl) :: rem ->
       let tree = Printtyp.tree_of_exception_declaration id decl in
       Some (tree, None, rem)
-  | Tsig_module(id, mty) :: rem ->
-      let tree = Printtyp.tree_of_module id mty in
+  | Tsig_module(id, mty, rs) :: rem ->
+      let tree = Printtyp.tree_of_module id mty rs in
       Some (tree, None, rem)
   | Tsig_modtype(id, decl) :: rem ->
       let tree = Printtyp.tree_of_modtype_declaration id decl in
       Some (tree, None, rem)
-  | Tsig_class(id, decl) :: cltydecl :: tydecl1 :: tydecl2 :: rem ->
-      let tree = Printtyp.tree_of_class_declaration id decl in
+  | Tsig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem ->
+      let tree = Printtyp.tree_of_class_declaration id decl rs in
       Some (tree, None, rem)
-  | Tsig_cltype(id, decl) :: tydecl1 :: tydecl2 :: rem ->
-      let tree = Printtyp.tree_of_cltype_declaration id decl in
+  | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
+      let tree = Printtyp.tree_of_cltype_declaration id decl rs in
       Some (tree, None, rem)
   | _ -> None
 
@@ -310,6 +316,26 @@ let use_silently ppf name =
 let first_line = ref true
 let got_eof = ref false;;
 
+let read_input_default prompt buffer len =
+  output_string stdout prompt; flush stdout;
+  let i = ref 0 in
+  try
+    while true do
+      if !i >= len then raise Exit;
+      let c = input_char stdin in
+      buffer.[!i] <- c;
+      incr i;
+      if c = '\n' then raise Exit;
+    done;
+    (!i, false)
+  with
+  | End_of_file ->
+      (!i, true)
+  | Exit ->
+      (!i, false)
+
+let read_interactive_input = ref read_input_default
+
 let refill_lexbuf buffer len =
   if !got_eof then (got_eof := false; 0) else begin
     let prompt =
@@ -317,23 +343,14 @@ let refill_lexbuf buffer len =
       else if Lexer.in_comment () then "* "
       else "  "
     in
-    output_string stdout prompt; flush stdout;
     first_line := false;
-    let i = ref 0 in
-    try
-      while true do
-        if !i >= len then raise Exit;
-        let c = input_char stdin in
-        buffer.[!i] <- c;
-        incr i;
-        if c = '\n' then raise Exit;
-      done;
-      !i
-    with
-    | End_of_file ->
-        Location.echo_eof ();
-        if !i > 0 then (got_eof := true; !i) else 0
-    | Exit -> !i
+    let (len, eof) = !read_interactive_input prompt buffer len in
+    if eof then begin
+      Location.echo_eof ();
+      if len > 0 then got_eof := true;
+      len
+    end else
+      len
   end
 
 (* Toplevel initialization. Performed here instead of at the
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index ee7470b7..7093f1b3 100644
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: toploop.mli,v 1.24 2003/06/30 15:31:06 xleroy Exp $ *)
+(* $Id: toploop.mli,v 1.25 2004/05/15 09:59:37 xleroy Exp $ *)
 
 open Format
 
@@ -98,6 +98,10 @@ val print_out_signature :
 val print_out_phrase :
   (formatter -> Outcometree.out_phrase -> unit) ref
 
+(* Hooks for external line editor *)
+
+val read_interactive_input : (string -> string -> int -> int * bool) ref
+
 (* Hooks for initialization *)
 
 val toplevel_startup_hook : (unit -> unit) ref
diff --git a/typing/btype.ml b/typing/btype.ml
index 4dc4b4e1..684d3824 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: btype.ml,v 1.33 2003/08/09 11:47:57 garrigue Exp $ *)
+(* $Id: btype.ml,v 1.35 2004/01/06 13:41:39 garrigue Exp $ *)
 
 (* Basic operations on core types *)
 
@@ -77,13 +77,31 @@ let rec row_field_repr_aux tl = function
 
 let row_field_repr fi = row_field_repr_aux [] fi
 
-let rec row_repr row =
+let rec rev_concat l ll =
+  match ll with
+    [] -> l
+  | l'::ll -> rev_concat (l'@l) ll
+
+let rec row_repr_aux ll row =
   match (repr row.row_more).desc with
   | Tvariant row' ->
-      if row.row_fields = [] then row_repr row' else
-      let row' = row_repr row' in
-      {row' with row_fields = row.row_fields @ row'.row_fields}
-  | _ -> row
+      let f = row.row_fields in
+      row_repr_aux (if f = [] then ll else f::ll) row'
+  | _ ->
+      if ll = [] then row else
+      {row with row_fields = rev_concat row.row_fields ll}
+
+let row_repr row = row_repr_aux [] row
+
+let rec row_field tag row =
+  let rec find = function
+    | (tag',f) :: fields ->
+	if tag = tag' then row_field_repr f else find fields
+    | [] ->
+	match repr row.row_more with
+	| {desc=Tvariant row'} -> row_field tag row'
+	| _ -> Rabsent
+  in find row.row_fields
 
 let rec row_more row =
   match repr row.row_more with
@@ -295,6 +313,26 @@ let rec unmark_class_type =
                   (*  Memorization of abbreviation expansion *)
                   (*******************************************)
 
+(* Search whether the expansion has been memorized. *)
+let rec find_expans p1 = function
+    Mnil -> None
+  | Mcons (p2, ty0, ty, _) when Path.same p1 p2 -> Some ty
+  | Mcons (_, _, _, rem)   -> find_expans p1 rem
+  | Mlink {contents = rem} -> find_expans p1 rem
+
+(* debug: check for cycles in abbreviation. only works with -principal
+let rec check_expans visited ty =
+  let ty = repr ty in
+  assert (not (List.memq ty visited));
+  match ty.desc with
+    Tconstr (path, args, abbrev) ->
+      begin match find_expans path !abbrev with
+        Some ty' -> check_expans (ty :: visited) ty'
+      | None -> ()
+      end
+  | _ -> ()
+*)
+
 let memo = ref []
         (* Contains the list of saved abbreviation expansions. *)
 
@@ -305,12 +343,8 @@ let cleanup_abbrev () =
 
 let memorize_abbrev mem path v v' =
         (* Memorize the expansion of an abbreviation. *)
-  (* assert
-    begin match (repr v').desc with
-      Tconstr (path', _, _) when Path.same path path'-> false
-    | _ -> true
-    end; *)
   mem := Mcons (path, v, v', !mem);
+  (* check_expans [] v; *)
   memo := mem :: !memo
 
 let rec forget_abbrev_rec mem path =
@@ -328,20 +362,17 @@ let rec forget_abbrev_rec mem path =
 let forget_abbrev mem path =
   try mem := forget_abbrev_rec !mem path with Exit -> ()
 
-let rec check_abbrev_rec path = function
+(* debug: check for invalid abbreviations
+let rec check_abbrev_rec = function
     Mnil -> true
-  | Mcons (path', _, ty, rem) ->
-      if Path.same path path' && 
-        match repr ty with
-          {desc = Tconstr(path',_,_)} -> Path.same path path'
-        | _ -> false
-      then false
-      else check_abbrev_rec path rem
+  | Mcons (_, ty1, ty2, rem) ->
+      repr ty1 != repr ty2
   | Mlink mem' ->
-      check_abbrev_rec path !mem'
+      check_abbrev_rec !mem'
 
-let check_memorized_abbrevs path =
-  List.for_all (fun mem -> check_abbrev_rec path !mem) !memo
+let check_memorized_abbrevs () =
+  List.for_all (fun mem -> check_abbrev_rec !mem) !memo
+*)
 
                   (**********************************)
                   (*  Utilities for labels          *)
@@ -406,10 +437,8 @@ let log_change ch =
 let log_type ty =
   if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
 let link_type ty ty' = log_type ty; ty.desc <- Tlink ty'
-(*match repr ty' with
-    {desc=Tconstr(path,_,_)} -> assert (check_memorized_abbrevs path)
-  | _ -> ()
-*)
+  (* ; assert (check_memorized_abbrevs ()) *)
+  (*  ; check_expans [] ty' *)
 let set_level ty level =
   if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
   ty.level <- level
diff --git a/typing/btype.mli b/typing/btype.mli
index 9437d1aa..329a4cf9 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: btype.mli,v 1.14 2003/05/19 09:21:17 garrigue Exp $ *)
+(* $Id: btype.mli,v 1.16 2004/01/06 13:41:39 garrigue Exp $ *)
 
 (* Basic operations on core types *)
 
@@ -46,6 +46,7 @@ val commu_repr: commutable -> commutable
 val row_repr: row_desc -> row_desc
         (* Return the canonical representative of a row description *)
 val row_field_repr: row_field -> row_field
+val row_field: label -> row_desc -> row_field
         (* Return the canonical representative of a row field *)
 val row_more: row_desc -> type_expr
         (* Return the extension variable of the row *)
@@ -97,6 +98,8 @@ val unmark_class_signature: class_signature -> unit
 
 (**** Memorization of abbreviation expansion ****)
 
+val find_expans: Path.t -> abbrev_memo -> type_expr option
+        (* Look up a memorized abbreviation *)
 val cleanup_abbrev: unit -> unit
         (* Flush the cache of abbreviation expansions.
            When some types are saved (using [output_value]), this
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 80a647f2..c08b3051 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ctype.ml,v 1.170 2003/09/25 08:05:38 xleroy Exp $ *)
+(* $Id: ctype.ml,v 1.179.2.1 2004/07/07 01:45:21 garrigue Exp $ *)
 
 (* Operations on core types *)
 
@@ -177,6 +177,8 @@ module TypePairs =
 
 (**** Object field manipulation. ****)
 
+let dummy_method = "*dummy method*"
+
 let object_fields ty =
   match (repr ty).desc with
     Tobject (fields, _) -> fields
@@ -222,6 +224,7 @@ let rec opened_object ty =
     Tobject (t, _)     -> opened_object t
   | Tfield(_, _, _, t) -> opened_object t
   | Tvar               -> true
+  | Tunivar            -> true
   | _                  -> false
 
 (**** Close an object ****)
@@ -452,7 +455,7 @@ let closed_class params sign =
   List.iter mark_type params;
   mark_type rest;
   List.iter
-    (fun (lab, _, ty) -> if lab = "*dummy method*" then mark_type ty)
+    (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
     fields;
   try
     mark_type_node (repr sign.cty_self);
@@ -603,13 +606,8 @@ let rec update_level env level ty =
         end;
         set_level ty level;
         iter_type_expr (update_level env level) ty
-    | Tfield(_, k, _, _) ->
-        begin match field_kind_repr k with
-          Fvar _ (* {contents = None} *) -> raise (Unify [(ty, newvar2 level)])
-        | _                              -> ()
-        end;
-        set_level ty level;
-        iter_type_expr (update_level env level) ty
+    | Tfield(lab, _, _, _) when lab = dummy_method ->
+        raise (Unify [(ty, newvar2 level)])
     | _ ->
         set_level ty level;
         (* XXX what about abbreviations in Tconstr ? *)
@@ -824,7 +822,9 @@ let instance_class params cty =
           {cty_self = copy sign.cty_self;
            cty_vars =
              Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
-           cty_concr = sign.cty_concr}
+           cty_concr = sign.cty_concr;
+           cty_inher =
+             List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher}
     | Tcty_fun (l, ty, cty) ->
         Tcty_fun (l, copy ty, copy_class_type cty)
   in
@@ -1004,26 +1004,6 @@ let apply env params body args =
                               (*  Abbreviation expansion  *)
                               (****************************)
 
-
-(* Search whether the expansion has been memorized. *)
-let rec find_expans p1 =
-  function
-    Mnil ->
-      None
-  | Mcons (p2, ty0, ty, _) when Path.same p1 p2 ->
-      (* assert
-        begin match (repr ty).desc with
-          Tconstr (p3, _, _) when Path.same p2 p3-> false
-        | _ -> true
-        end;
-      assert (repr ty0 != repr ty); *)
-      Some ty
-  | Mcons (_, _, _, rem) ->
-      find_expans p1 rem
-  | Mlink {contents = rem} ->
-      find_expans p1 rem
-
-
 (* 
    If the environnement has changed, memorized expansions might not
    be correct anymore, and so we flush the cache. This is safe but
@@ -1246,21 +1226,21 @@ let occur env ty0 ty =
    be done at meta-level, using bindings in univar_pairs *)
 let rec unify_univar t1 t2 = function
     (cl1, cl2) :: rem ->
-      let repr_univ = List.map (fun (t,o) -> repr t, o) in
-      let cl1 = repr_univ cl1 and cl2 = repr_univ cl2 in
-      begin try
-        let r1 = List.assq t1 cl1 in
-        match !r1 with
-          Some t -> if t2 != repr t then raise (Unify [])
-        | None ->
-            try
-              let r2 = List.assq t2 cl2 in
-              if !r2 <> None then raise (Unify []);
-              set_univar r1 t2; set_univar r2 t1
-            with Not_found ->
-              raise (Unify [])
-      with Not_found ->
-        unify_univar t1 t2 rem
+      let find_univ t cl =
+        try
+          let (_, r) = List.find (fun (t',_) -> t == repr t') cl in
+          Some r
+        with Not_found -> None
+      in
+      begin match find_univ t1 cl1, find_univ t2 cl2 with
+        Some {contents=Some t'2}, Some _ when t2 == repr t'2 ->
+          ()
+      | Some({contents=None} as r1), Some({contents=None} as r2) ->
+          set_univar r1 t2; set_univar r2 t1
+      | None, None ->
+          unify_univar t1 t2 rem
+      | _ ->
+          raise (Unify [])
       end
   | [] -> raise (Unify [])
 
@@ -1322,6 +1302,13 @@ let expand_trace env trace =
        (repr t1, full_expand env t1)::(repr t2, full_expand env t2)::rem)
     trace []
 
+(* build a dummy variant type *)
+let mkvariant fields closed =
+  newgenty
+    (Tvariant
+       {row_fields = fields; row_closed = closed; row_more = newvar();
+        row_bound = []; row_fixed = false; row_name = None })
+
 (**** Unification ****)
 
 (* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
@@ -1404,11 +1391,14 @@ let rec unify env t1 t2 =
 
 and unify2 env t1 t2 =
   (* Second step: expansion of abbreviations *)
-  let t1' = expand_head env t1 in
-  let t2' = expand_head env t2 in
-  (* Expansion may have changed the representative of the types... *)
-  let t1' = expand_head env t1' in
-  let t2' = expand_head env t2' in
+  let rec expand_both t1'' t2'' =
+    let t1' = expand_head env t1 in
+    let t2' = expand_head env t2 in
+    (* Expansion may have changed the representative of the types... *)
+    if t1' == t1'' && t2' == t2'' then (t1',t2') else
+    expand_both t1' t2'
+  in
+  let t1', t2' = expand_both t1 t2 in
   if t1' == t2' then () else
 
   let t1 = repr t1 and t2 = repr t2 in
@@ -1465,7 +1455,7 @@ and unify3 env t1 t1' t2 t2' =
         (* XXX One should do some kind of unification... *)
         begin match (repr t2').desc with
           Tobject (_, {contents = Some (_, va::_)})
-          when let va = repr va in va.desc = Tvar || va.desc = Tunivar ->
+          when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] ->
             ()
         | Tobject (_, nm2) ->
             set_name nm2 !nm1
@@ -1476,6 +1466,11 @@ and unify3 env t1 t1' t2 t2' =
         unify_row env row1 row2
     | (Tfield _, Tfield _) ->           (* Actually unused *)
         unify_fields env t1' t2'
+    | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
+        begin match field_kind_repr kind with
+          Fvar r when f <> dummy_method -> set_kind r Fabsent
+        | _      -> raise (Unify [])
+        end
     | (Tnil, Tnil) ->
         ()
     | (Tpoly (t1, []), Tpoly (t2, [])) ->
@@ -1555,15 +1550,16 @@ and unify_fields env ty1 ty2 =          (* Optimization *)
   let (fields1, rest1) = flatten_fields ty1
   and (fields2, rest2) = flatten_fields ty2 in
   let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let l1 = (repr ty1).level and l2 = (repr ty2).level in
   let va =
     if miss1 = [] then rest2
     else if miss2 = [] then rest1
-    else newvar ()
+    else newty2 (min l1 l2) Tvar
   in
   let d1 = rest1.desc and d2 = rest2.desc in
   try
-    unify env (build_fields (repr ty1).level miss1 va) rest2;
-    unify env rest1 (build_fields (repr ty2).level miss2 va);
+    unify env (build_fields l1 miss1 va) rest2;
+    unify env rest1 (build_fields l2 miss2 va);
     List.iter
       (fun (n, k1, t1, k2, t2) ->
         unify_kind k1 k2;
@@ -1615,11 +1611,6 @@ and unify_row env row1 row2 =
         row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent)
       pairs
   in
-  let mkvariant fields closed =
-    newgenty
-      (Tvariant
-         {row_fields = fields; row_closed = closed; row_more = newvar();
-          row_bound = []; row_fixed = false; row_name = None }) in
   let empty fields =
     List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in
   (* Check whether we are going to build an empty type *)
@@ -1665,19 +1656,29 @@ and unify_row env row1 row2 =
   begin try
     set_more row1 r2;
     set_more row2 r1;
+    let undo = ref [] in
     List.iter
       (fun (l,f1,f2) ->
-        unify_row_field env row1.row_fixed row2.row_fixed f1 f2)
+        try unify_row_field env row1.row_fixed row2.row_fixed undo l f1 f2
+        with Unify trace ->
+          raise (Unify ((mkvariant [l,f1] true,
+                         mkvariant [l,f2] true) :: trace)))
       pairs;
     (* Special case when there is only one field left *)
     if row0.row_closed then begin
       match filter_row_fields false (row_repr row1).row_fields with [l, fi] ->
         begin match row_field_repr fi with
-          Reither(c, t1::tl, _, e) ->
-            if c then raise (Unify []);
-            set_row_field e (Rpresent (Some t1));
-            (try List.iter (unify env t1) tl
-            with exn -> e := None; raise exn)
+          Reither(c, t1::tl, _, e) as f1 ->
+            let f1' = Rpresent (Some t1) in
+            set_row_field e f1';
+            begin try
+              if c then raise (Unify []);
+              List.iter (unify env t1) tl
+            with exn ->
+              e := None;
+              List.assoc l !undo := Some f1';
+              raise exn
+            end
         | Reither(true, [], _, e) ->
             set_row_field e (Rpresent None);
         | _ -> ()
@@ -1688,7 +1689,7 @@ and unify_row env row1 row2 =
     log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
   end
 
-and unify_row_field env fixed1 fixed2 f1 f2 =
+and unify_row_field env fixed1 fixed2 undo l f1 f2 =
   let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
   if f1 == f2 then () else
   match f1, f2 with
@@ -1704,7 +1705,7 @@ and unify_row_field env fixed1 fixed2 f1 f2 =
             List.iter (unify env t1) tl;
             !e1 <> None || !e2 <> None
         end in
-      if redo then unify_row_field env fixed1 fixed2 f1 f2 else
+      if redo then unify_row_field env fixed1 fixed2 undo l f1 f2 else
       let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
       let rec remq tl = function [] -> []
         | ty :: tl' ->
@@ -1712,9 +1713,10 @@ and unify_row_field env fixed1 fixed2 f1 f2 =
       in
       let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
       let e = ref None in
-      let f1 = Reither(c1 || c2, tl1', m1 || m2, e)
-      and f2 = Reither(c1 || c2, tl2', m1 || m2, e) in
-      set_row_field e1 f1; set_row_field e2 f2
+      let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
+      and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
+      set_row_field e1 f1'; set_row_field e2 f2';
+      undo := (l, e2) :: !undo
   | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2
   | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1
   | Rabsent, Rabsent -> ()
@@ -1731,6 +1733,7 @@ and unify_row_field env fixed1 fixed2 f1 f2 =
   | Rpresent None, Reither(true, [], _, e2) when not fixed2 ->
       set_row_field e2 f1
   | _ -> raise (Unify [])
+    
 
 let unify env ty1 ty2 =
   try
@@ -2578,6 +2581,24 @@ let rec filter_visited = function
 let memq_warn t visited =
   if List.memq t visited then (warn := true; true) else false
 
+let rec lid_of_path sharp = function
+    Path.Pident id ->
+      Longident.Lident (sharp ^ Ident.name id)
+  | Path.Pdot (p1, s, _) ->
+      Longident.Ldot (lid_of_path "" p1, sharp ^ s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
+
+let find_cltype_for_path env p =
+  let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
+  match cl_abbr.type_manifest with
+    Some ty ->
+      begin match (repr ty).desc with
+        Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty
+      | _ -> raise Not_found
+      end
+  | None -> assert false
+
 let rec build_subtype env visited loops posi level t =
   let t = repr t in
   match t.desc with
@@ -2613,22 +2634,7 @@ let rec build_subtype env visited loops posi level t =
       let level' = pred_expand level in
       begin try match t'.desc with
         Tobject _ when posi && not (opened_object t') ->
-          let rec lid_of_path sharp = function
-              Path.Pident id ->
-                Longident.Lident (sharp ^ Ident.name id)
-            | Path.Pdot (p1, s, _) ->
-                Longident.Ldot (lid_of_path "" p1, sharp ^ s)
-            | Path.Papply (p1, p2) ->
-                Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
-          in
-          let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
-          let body =
-            match cl_abbr.type_manifest with Some ty ->
-              begin match (repr ty).desc with
-                Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> ty
-              | _ -> raise Not_found
-              end
-            | None -> assert false in
+          let cl_abbr, body = find_cltype_for_path env p in
           let ty =
             subst env !current_level abbrev None cl_abbr.type_params tl body in
           let ty = repr ty in
@@ -3175,7 +3181,10 @@ let nondep_class_signature env id sign =
     cty_vars =
       Vars.map (function (m, t) -> (m, nondep_type_rec env id t))
         sign.cty_vars;
-    cty_concr = sign.cty_concr }
+    cty_concr = sign.cty_concr;
+    cty_inher =
+      List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl))
+        sign.cty_inher }
 
 let rec nondep_class_type env id =
   function
diff --git a/typing/ctype.mli b/typing/ctype.mli
index cb854d8a..6d8ad2b7 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ctype.mli,v 1.51 2003/07/08 10:00:43 garrigue Exp $ *)
+(* $Id: ctype.mli,v 1.52 2003/11/25 09:20:41 garrigue Exp $ *)
 
 (* Operations on core types *)
 
@@ -53,6 +53,7 @@ val none: type_expr
 val repr: type_expr -> type_expr
         (* Return the canonical representative of a type. *)
 
+val dummy_method: label
 val object_fields: type_expr -> type_expr
 val flatten_fields:
         type_expr -> (string * field_kind * type_expr) list * type_expr
@@ -72,6 +73,7 @@ val set_object_name:
         Ident.t -> type_expr -> type_expr list -> type_expr -> unit
 val remove_object_name: type_expr -> unit
 val hide_private_methods: type_expr -> unit
+val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
 
 val sort_row_fields: (label * row_field) list -> (label * row_field) list
 val merge_row_fields:
@@ -189,7 +191,7 @@ val match_class_declarations:
 
 val enlarge_type: Env.t -> type_expr -> type_expr * bool
         (* Make a type larger, flag is true if some pruning had to be done *)
-val subtype : Env.t -> type_expr -> type_expr -> unit -> unit
+val subtype: Env.t -> type_expr -> type_expr -> unit -> unit
         (* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
            It accumulates the constraints the type variables must
            enforce and returns a function that inforce this
diff --git a/typing/env.ml b/typing/env.ml
index 2d7a5404..5aa95fcf 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: env.ml,v 1.52 2003/07/02 09:14:33 xleroy Exp $ *)
+(* $Id: env.ml,v 1.54 2004/06/12 08:55:47 xleroy Exp $ *)
 
 (* Environment handling *)
 
@@ -88,6 +88,20 @@ let empty = {
   cltypes = Ident.empty;
   summary = Env_empty }
 
+let diff_keys tbl1 tbl2 =
+  let keys2 = Ident.keys tbl2 in
+  List.filter
+    (fun id ->
+      match Ident.find_same id tbl2 with Pident _, _ ->
+        (try ignore (Ident.find_same id tbl1); false with Not_found -> true)
+      | _ -> false)
+    keys2
+
+let diff env1 env2 =
+  diff_keys env1.values env2.values @
+  diff_keys env1.modules env2.modules @
+  diff_keys env1.classes env2.classes
+
 (* Forward declarations *)
 
 let components_of_module' =
@@ -406,7 +420,7 @@ let rec prefix_idents root pos sub = function
       let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in
       let (pl, final_sub) = prefix_idents root nextpos sub rem in
       (p::pl, final_sub)
-  | Tsig_type(id, decl) :: rem ->
+  | Tsig_type(id, decl, _) :: rem ->
       let p = Pdot(root, Ident.name id, nopos) in
       let (pl, final_sub) =
         prefix_idents root pos (Subst.add_type id p sub) rem in
@@ -415,7 +429,7 @@ let rec prefix_idents root pos sub = function
       let p = Pdot(root, Ident.name id, pos) in
       let (pl, final_sub) = prefix_idents root (pos+1) sub rem in
       (p::pl, final_sub)
-  | Tsig_module(id, mty) :: rem ->
+  | Tsig_module(id, mty, _) :: rem ->
       let p = Pdot(root, Ident.name id, pos) in
       let (pl, final_sub) =
         prefix_idents root (pos+1) (Subst.add_module id p sub) rem in
@@ -426,11 +440,11 @@ let rec prefix_idents root pos sub = function
         prefix_idents root pos
                       (Subst.add_modtype id (Tmty_ident p) sub) rem in
       (p::pl, final_sub)
-  | Tsig_class(id, decl) :: rem ->
+  | Tsig_class(id, decl, _) :: rem ->
       let p = Pdot(root, Ident.name id, pos) in
       let (pl, final_sub) = prefix_idents root (pos + 1) sub rem in
       (p::pl, final_sub)
-  | Tsig_cltype(id, decl) :: rem ->
+  | Tsig_cltype(id, decl, _) :: rem ->
       let p = Pdot(root, Ident.name id, nopos) in
       let (pl, final_sub) = prefix_idents root pos sub rem in
       (p::pl, final_sub)
@@ -458,7 +472,7 @@ let rec components_of_module env sub path mty =
             begin match decl.val_kind with
               Val_prim _ -> () | _ -> incr pos
             end
-        | Tsig_type(id, decl) ->
+        | Tsig_type(id, decl, _) ->
             let decl' = Subst.type_declaration sub decl in
             c.comp_types <-
               Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
@@ -477,7 +491,7 @@ let rec components_of_module env sub path mty =
             c.comp_constrs <-
               Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
             incr pos
-        | Tsig_module(id, mty) ->
+        | Tsig_module(id, mty, _) ->
             let mty' = Subst.modtype sub mty in
             c.comp_modules <-
               Tbl.add (Ident.name id) (mty', !pos) c.comp_modules;
@@ -491,12 +505,12 @@ let rec components_of_module env sub path mty =
             c.comp_modtypes <-
               Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
             env := store_modtype id path decl !env
-        | Tsig_class(id, decl) ->
+        | Tsig_class(id, decl, _) ->
             let decl' = Subst.class_declaration sub decl in
             c.comp_classes <-
               Tbl.add (Ident.name id) (decl', !pos) c.comp_classes;
             incr pos
-        | Tsig_cltype(id, decl) ->
+        | Tsig_cltype(id, decl, _) ->
             let decl' = Subst.cltype_declaration sub decl in
             c.comp_cltypes <-
               Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes)
@@ -638,12 +652,12 @@ and enter_cltype = enter store_cltype
 let add_item comp env =
   match comp with
     Tsig_value(id, decl)     -> add_value id decl env
-  | Tsig_type(id, decl)      -> add_type id decl env
+  | Tsig_type(id, decl, _)   -> add_type id decl env
   | Tsig_exception(id, decl) -> add_exception id decl env
-  | Tsig_module(id, mty)     -> add_module id mty env
+  | Tsig_module(id, mty, _)  -> add_module id mty env
   | Tsig_modtype(id, decl)   -> add_modtype id decl env
-  | Tsig_class(id, decl)     -> add_class id decl env
-  | Tsig_cltype(id, decl)    -> add_cltype id decl env
+  | Tsig_class(id, decl, _)  -> add_class id decl env
+  | Tsig_cltype(id, decl, _) -> add_cltype id decl env
 
 let rec add_signature sg env =
   match sg with
@@ -663,21 +677,21 @@ let open_signature root sg env =
           Tsig_value(id, decl) ->
             store_value (Ident.hide id) p
                         (Subst.value_description sub decl) env
-        | Tsig_type(id, decl) ->
+        | Tsig_type(id, decl, _) ->
             store_type (Ident.hide id) p
                        (Subst.type_declaration sub decl) env
         | Tsig_exception(id, decl) ->
             store_exception (Ident.hide id) p
                             (Subst.exception_declaration sub decl) env
-        | Tsig_module(id, mty) ->
+        | Tsig_module(id, mty, _) ->
             store_module (Ident.hide id) p (Subst.modtype sub mty) env
         | Tsig_modtype(id, decl) ->
             store_modtype (Ident.hide id) p
                           (Subst.modtype_declaration sub decl) env
-        | Tsig_class(id, decl) ->
+        | Tsig_class(id, decl, _) ->
             store_class (Ident.hide id) p
                         (Subst.class_declaration sub decl) env
-        | Tsig_cltype(id, decl) ->
+        | Tsig_cltype(id, decl, _) ->
             store_cltype (Ident.hide id) p
                          (Subst.cltype_declaration sub decl) env)
       env sg pl in
diff --git a/typing/env.mli b/typing/env.mli
index 8354d14a..3def241c 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: env.mli,v 1.27 2002/11/17 16:42:11 xleroy Exp $ *)
+(* $Id: env.mli,v 1.28 2003/11/25 09:20:42 garrigue Exp $ *)
 
 (* Environment handling *)
 
@@ -20,6 +20,7 @@ type t
 
 val empty: t
 val initial: t
+val diff: t -> t -> Ident.t list
 
 (* Lookup by paths *)
 
diff --git a/typing/ident.ml b/typing/ident.ml
index b5c065e4..a30aa7a4 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -10,11 +10,14 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ident.ml,v 1.21 2003/05/12 09:34:04 xleroy Exp $ *)
+(* $Id: ident.ml,v 1.23 2004/01/04 14:32:34 doligez Exp $ *)
 
 open Format
 
-type t = { stamp: int; name: string; mutable global: bool }
+type t = { stamp: int; name: string; mutable flags: int }
+
+let global_flag = 1
+let predef_exn_flag = 2
 
 (* A stamp of 0 denotes a persistent identifier *)
 
@@ -22,10 +25,14 @@ let currentstamp = ref 0
 
 let create s =
   incr currentstamp;
-  { name = s; stamp = !currentstamp; global = false }
+  { name = s; stamp = !currentstamp; flags = 0 }
+
+let create_predef_exn s =
+  incr currentstamp;
+  { name = s; stamp = !currentstamp; flags = predef_exn_flag }
 
 let create_persistent s =
-  { name = s; stamp = 0; global = true }
+  { name = s; stamp = 0; flags = global_flag }
 
 let rename i =
   incr currentstamp;
@@ -33,6 +40,8 @@ let rename i =
 
 let name i = i.name
 
+let stamp i = i.stamp
+
 let unique_name i = i.name ^ "_" ^ string_of_int i.stamp
 
 let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp
@@ -63,16 +72,19 @@ let hide i =
   { i with stamp = -1 }
 
 let make_global i =
-  i.global <- true
+  i.flags <- i.flags lor global_flag
 
 let global i =
-  i.global
+  (i.flags land global_flag) <> 0
+
+let is_predef_exn i =
+  (i.flags land predef_exn_flag) <> 0
 
 let print ppf i =
   match i.stamp with
   | 0 -> fprintf ppf "%s!" i.name
   | -1 -> fprintf ppf "%s#" i.name
-  | n -> fprintf ppf "%s/%i%s" i.name n (if i.global then "g" else "")
+  | n -> fprintf ppf "%s/%i%s" i.name n (if global i then "g" else "")
 
 type 'a tbl =
     Empty
@@ -159,3 +171,14 @@ let rec find_name name = function
         k.data
       else
         find_name name (if c < 0 then l else r)
+
+let rec keys_aux stack accu = function
+    Empty ->
+      begin match stack with
+        [] -> accu
+      | a :: l -> keys_aux l accu a
+      end
+  | Node(l, k, r, _) ->
+      keys_aux (l :: stack) (k.ident :: accu) r
+
+let keys tbl = keys_aux [] [] tbl
diff --git a/typing/ident.mli b/typing/ident.mli
index 598b2369..9f7372cb 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ident.mli,v 1.15 2003/05/12 09:34:04 xleroy Exp $ *)
+(* $Id: ident.mli,v 1.17 2004/01/04 14:32:34 doligez Exp $ *)
 
 (* Identifiers (unique names) *)
 
@@ -18,6 +18,7 @@ type t
 
 val create: string -> t
 val create_persistent: string -> t
+val create_predef_exn: string -> t
 val rename: t -> t
 val name: t -> string
 val unique_name: t -> string
@@ -39,6 +40,7 @@ val hide: t -> t
 
 val make_global: t -> unit
 val global: t -> bool
+val is_predef_exn: t -> bool
 
 val binding_time: t -> int
 val current_time: unit -> int
@@ -54,3 +56,4 @@ val empty: 'a tbl
 val add: t -> 'a -> 'a tbl -> 'a tbl
 val find_same: t -> 'a tbl -> 'a
 val find_name: string -> 'a tbl -> 'a
+val keys: 'a tbl -> t list
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 025ba527..bdaaa3cd 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: includemod.ml,v 1.32 2003/07/27 17:02:33 xleroy Exp $ *)
+(* $Id: includemod.ml,v 1.34 2004/06/12 08:55:47 xleroy Exp $ *)
 
 (* Inclusion checks for the module language *)
 
@@ -104,26 +104,24 @@ type field_desc =
 
 let item_ident_name = function
     Tsig_value(id, _) -> (id, Field_value(Ident.name id))
-  | Tsig_type(id, _) -> (id, Field_type(Ident.name id))
+  | Tsig_type(id, _, _) -> (id, Field_type(Ident.name id))
   | Tsig_exception(id, _) -> (id, Field_exception(Ident.name id))
-  | Tsig_module(id, _) -> (id, Field_module(Ident.name id))
+  | Tsig_module(id, _, _) -> (id, Field_module(Ident.name id))
   | Tsig_modtype(id, _) -> (id, Field_modtype(Ident.name id))
-  | Tsig_class(id, _) -> (id, Field_class(Ident.name id))
-  | Tsig_cltype(id, _) -> (id, Field_classtype(Ident.name id))
+  | Tsig_class(id, _, _) -> (id, Field_class(Ident.name id))
+  | Tsig_cltype(id, _, _) -> (id, Field_classtype(Ident.name id))
 
 (* Simplify a structure coercion *)
 
-let simplify_structure_coercion cc =
-  let pos = ref 0 in
-  try
-    List.iter
-      (fun (n, c) ->
-        if n <> !pos || c <> Tcoerce_none then raise Exit;
-        incr pos)
-      cc;
-    Tcoerce_none
-  with Exit ->
-    Tcoerce_structure cc
+let simplify_structure_coercion init_size cc =
+  let rec is_identity_coercion pos = function
+  | [] ->
+      pos = init_size
+  | (n, c) :: rem ->
+      n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in
+  if is_identity_coercion 0 cc
+  then Tcoerce_none
+  else Tcoerce_structure cc
 
 (* Inclusion between module types. 
    Return the restriction that transforms a value of the smaller type
@@ -178,22 +176,22 @@ and signatures env subst sig1 sig2 =
   (* Build a table of the components of sig1, along with their positions.
      The table is indexed by kind and name of component *)
   let rec build_component_table pos tbl = function
-      [] -> tbl
+      [] -> (tbl, pos)
     | item :: rem ->
         let (id, name) = item_ident_name item in
         let nextpos =
           match item with
             Tsig_value(_,{val_kind = Val_prim _})
-          | Tsig_type(_,_)
+          | Tsig_type(_,_,_)
           | Tsig_modtype(_,_)
-          | Tsig_cltype(_,_) -> pos
+          | Tsig_cltype(_,_,_) -> pos
           | Tsig_value(_,_)
           | Tsig_exception(_,_)
-          | Tsig_module(_,_)
-          | Tsig_class(_, _) -> pos+1 in
+          | Tsig_module(_,_,_)
+          | Tsig_class(_, _,_) -> pos+1 in
         build_component_table nextpos
                               (Tbl.add name (id, item, pos) tbl) rem in
-  let comps1 =
+  let (comps1, size1) =
     build_component_table 0 Tbl.empty sig1 in
   (* Pair each component of sig2 with a component of sig1,
      identifying the names along the way.
@@ -227,7 +225,7 @@ and signatures env subst sig1 sig2 =
           pair_components subst paired (Missing_field id2 :: unpaired) rem
         end in
   (* Do the pairing and checking, and return the final coercion *)
-  simplify_structure_coercion(pair_components subst [] [] sig2)
+  simplify_structure_coercion size1 (pair_components subst [] [] sig2)
 
 (* Inclusion between signature components *)
 
@@ -239,24 +237,24 @@ and signature_components env subst = function
         Val_prim p -> signature_components env subst rem
       | _ -> (pos, cc) :: signature_components env subst rem
       end
-  | (Tsig_type(id1, tydecl1), Tsig_type(id2, tydecl2), pos) :: rem ->
+  | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
       type_declarations env subst id1 tydecl1 tydecl2;
       signature_components env subst rem
   | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
     :: rem ->
       exception_declarations env subst id1 excdecl1 excdecl2;
       (pos, Tcoerce_none) :: signature_components env subst rem
-  | (Tsig_module(id1, mty1), Tsig_module(id2, mty2), pos) :: rem ->
+  | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
       let cc =
         modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
       (pos, cc) :: signature_components env subst rem
   | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
       modtype_infos env subst id1 info1 info2;
       signature_components env subst rem
-  | (Tsig_class(id1, decl1), Tsig_class(id2, decl2), pos) :: rem ->
+  | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
       class_declarations env subst id1 decl1 decl2;
       (pos, Tcoerce_none) :: signature_components env subst rem
-  | (Tsig_cltype(id1, info1), Tsig_cltype(id2, info2), pos) :: rem ->
+  | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
       class_type_declarations env subst id1 info1 info2;
       signature_components env subst rem
   | _ ->
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 1c09800e..79520fb2 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: mtype.ml,v 1.22 2003/07/01 13:05:43 xleroy Exp $ *)
+(* $Id: mtype.ml,v 1.25 2004/06/12 08:55:47 xleroy Exp $ *)
 
 (* Operations on module types *)
 
@@ -28,6 +28,9 @@ let rec scrape env mty =
       end
   | _ -> mty
 
+let freshen mty =
+  Subst.modtype Subst.identity mty
+
 let rec strengthen env mty p =
   match scrape env mty with
     Tmty_signature sg ->
@@ -42,7 +45,7 @@ and strengthen_sig env sg p =
     [] -> []
   | (Tsig_value(id, desc) as sigelt) :: rem ->
       sigelt :: strengthen_sig env rem p
-  | Tsig_type(id, decl) :: rem ->
+  | Tsig_type(id, decl, rs) :: rem ->
       let newdecl =
         match decl.type_manifest with
           None ->
@@ -50,12 +53,12 @@ and strengthen_sig env sg p =
                 Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
                                             decl.type_params, ref Mnil))) }
         | _ -> decl in
-      Tsig_type(id, newdecl) :: strengthen_sig env rem p
+      Tsig_type(id, newdecl, rs) :: strengthen_sig env rem p
   | (Tsig_exception(id, d) as sigelt) :: rem ->
       sigelt :: strengthen_sig env rem p
-  | Tsig_module(id, mty) :: rem ->
-      Tsig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos))) ::
-      strengthen_sig (Env.add_module id mty env) rem p
+  | Tsig_module(id, mty, rs) :: rem ->
+      Tsig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos)), rs)
+      :: strengthen_sig (Env.add_module id mty env) rem p
       (* Need to add the module in case it defines manifest module types *)
   | Tsig_modtype(id, decl) :: rem ->
       let newdecl =
@@ -67,9 +70,9 @@ and strengthen_sig env sg p =
       Tsig_modtype(id, newdecl) ::
       strengthen_sig (Env.add_modtype id decl env) rem p
       (* Need to add the module type in case it is manifest *)
-  | (Tsig_class(id, decl) as sigelt) :: rem ->
+  | (Tsig_class(id, decl, rs) as sigelt) :: rem ->
       sigelt :: strengthen_sig env rem p
-  | (Tsig_cltype(id, decl) as sigelt) :: rem ->
+  | (Tsig_cltype(id, decl, rs) as sigelt) :: rem ->
       sigelt :: strengthen_sig env rem p
 
 (* In nondep_supertype, env is only used for the type it assigns to id.
@@ -101,12 +104,13 @@ let nondep_supertype env mid mty =
         Tsig_value(id, d) ->
           Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type;
                           val_kind = d.val_kind}) :: rem'
-      | Tsig_type(id, d) ->
-          Tsig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d) :: rem'
+      | Tsig_type(id, d, rs) ->
+          Tsig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs)
+          :: rem'
       | Tsig_exception(id, d) ->
           Tsig_exception(id, List.map (Ctype.nondep_type env mid) d) :: rem'
-      | Tsig_module(id, mty) ->
-          Tsig_module(id, nondep_mty va mty) :: rem'
+      | Tsig_module(id, mty, rs) ->
+          Tsig_module(id, nondep_mty va mty, rs) :: rem'
       | Tsig_modtype(id, d) ->
           begin try
             Tsig_modtype(id, nondep_modtype_decl d) :: rem'
@@ -115,10 +119,12 @@ let nondep_supertype env mid mty =
               Co -> Tsig_modtype(id, Tmodtype_abstract) :: rem'
             | _  -> raise Not_found
           end
-      | Tsig_class(id, d) ->
-          Tsig_class(id, Ctype.nondep_class_declaration env mid d) :: rem'
-      | Tsig_cltype(id, d) ->
-          Tsig_cltype(id, Ctype.nondep_cltype_declaration env mid d) :: rem'
+      | Tsig_class(id, d, rs) ->
+          Tsig_class(id, Ctype.nondep_class_declaration env mid d, rs)
+          :: rem'
+      | Tsig_cltype(id, d, rs) ->
+          Tsig_cltype(id, Ctype.nondep_cltype_declaration env mid d, rs)
+          :: rem'
 
   and nondep_modtype_decl = function
       Tmodtype_abstract -> Tmodtype_abstract
@@ -148,10 +154,12 @@ let rec enrich_modtype env p mty =
       mty
 
 and enrich_item env p = function
-    Tsig_type(id, decl) ->
-      Tsig_type(id, enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl)
-  | Tsig_module(id, mty) ->
-      Tsig_module(id, enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty)
+    Tsig_type(id, decl, rs) ->
+      Tsig_type(id,
+                enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs)
+  | Tsig_module(id, mty, rs) ->
+      Tsig_module(id,
+                  enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty, rs)
   | item -> item
 
 let rec type_paths env p mty =
@@ -166,9 +174,9 @@ and type_paths_sig env p pos sg =
   | Tsig_value(id, decl) :: rem ->
       let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in
       type_paths_sig env p pos' rem
-  | Tsig_type(id, decl) :: rem ->
+  | Tsig_type(id, decl, _) :: rem ->
       Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem
-  | Tsig_module(id, mty) :: rem ->
+  | Tsig_module(id, mty, _) :: rem ->
       type_paths env (Pdot(p, Ident.name id, pos)) mty @
       type_paths_sig (Env.add_module id mty env) p (pos+1) rem
   | Tsig_modtype(id, decl) :: rem ->
@@ -177,3 +185,25 @@ and type_paths_sig env p pos sg =
       type_paths_sig env p (pos+1) rem
   | (Tsig_cltype _) :: rem ->
       type_paths_sig env p pos rem
+
+let rec no_code_needed env mty =
+  match scrape env mty with
+    Tmty_ident p -> false
+  | Tmty_signature sg -> no_code_needed_sig env sg
+  | Tmty_functor(_, _, _) -> false  
+
+and no_code_needed_sig env sg =
+  match sg with
+    [] -> true
+  | Tsig_value(id, decl) :: rem ->
+      begin match decl.val_kind with
+      | Val_prim _ -> no_code_needed_sig env rem
+      | _ -> false
+      end
+  | Tsig_module(id, mty, _) :: rem ->
+      no_code_needed env mty &&
+      no_code_needed_sig (Env.add_module id mty env) rem
+  | (Tsig_type _ | Tsig_modtype _ | Tsig_cltype _) :: rem ->
+      no_code_needed_sig env rem
+  | (Tsig_exception _ | Tsig_class _) :: rem ->
+      false
diff --git a/typing/mtype.mli b/typing/mtype.mli
index b500b412..be0f7577 100644
--- a/typing/mtype.mli
+++ b/typing/mtype.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: mtype.mli,v 1.8 2003/07/01 13:05:43 xleroy Exp $ *)
+(* $Id: mtype.mli,v 1.10 2004/04/09 13:32:28 xleroy Exp $ *)
 
 (* Operations on module types *)
 
@@ -20,6 +20,9 @@ val scrape: Env.t -> module_type -> module_type
         (* Expand toplevel module type abbreviations
            till hitting a "hard" module type (signature, functor,
            or abstract module type ident. *)
+val freshen: module_type -> module_type
+        (* Return an alpha-equivalent copy of the given module type
+           where bound identifiers are fresh. *)
 val strengthen: Env.t -> module_type -> Path.t -> module_type
         (* Strengthen abstract type components relative to the
            given path. *)
@@ -27,6 +30,10 @@ val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type
         (* Return the smallest supertype of the given type
            in which the given ident does not appear.
            Raise [Not_found] if no such type exists. *)
+val no_code_needed: Env.t -> module_type -> bool
+val no_code_needed_sig: Env.t -> signature -> bool
+        (* Determine whether a module needs no implementation code,
+           i.e. consists only of type definitions. *)
 val enrich_modtype: Env.t -> Path.t -> module_type -> module_type
 val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration
 val type_paths: Env.t -> Path.t -> module_type -> Path.t list
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 2d905d45..7c004df9 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: oprint.ml,v 1.18 2003/07/29 09:11:13 xleroy Exp $ *)
+(* $Id: oprint.ml,v 1.19 2004/06/12 08:55:47 xleroy Exp $ *)
 
 open Format
 open Outcometree
@@ -317,12 +317,14 @@ and print_out_signature ppf =
       fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items
 and print_out_sig_item ppf =
   function
-    Osig_class (vir_flag, name, params, clt) ->
-      fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]"
+    Osig_class (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]"
+        (if rs = Orec_next then "and" else "class")
         (if vir_flag then " virtual" else "") print_out_class_params params
         name !out_class_type clt
-  | Osig_class_type (vir_flag, name, params, clt) ->
-      fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]"
+  | Osig_class_type (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]"
+        (if rs = Orec_next then "and" else "class type")
         (if vir_flag then " virtual" else "") print_out_class_params params
         name !out_class_type clt
   | Osig_exception (id, tyl) ->
@@ -331,9 +333,16 @@ and print_out_sig_item ppf =
       fprintf ppf "@[<2>module type %s@]" name
   | Osig_modtype (name, mty) ->
       fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
-  | Osig_module (name, mty) ->
-      fprintf ppf "@[<2>module %s :@ %a@]" name !out_module_type mty
-  | Osig_type tdl -> print_out_type_decl_list ppf tdl
+  | Osig_module (name, mty, rs) ->
+      fprintf ppf "@[<2>%s %s :@ %a@]" 
+        (match rs with Orec_not -> "module"
+                     | Orec_first -> "module rec"
+                     | Orec_next -> "and")
+        name !out_module_type mty
+  | Osig_type(td, rs) ->
+        print_out_type_decl
+          (if rs = Orec_next then "and" else "type")
+          ppf td
   | Osig_value (name, ty, prims) ->
       let kwd = if prims = [] then "val" else "external" in
       let pr_prims ppf =
@@ -345,13 +354,7 @@ and print_out_sig_item ppf =
       in
       fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name !out_type
         ty pr_prims prims
-and print_out_type_decl_list ppf =
-  function
-    [] -> ()
-  | [x] -> print_out_type_decl "type" ppf x
-  | x :: l ->
-      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
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 7051d231..75c3b589 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: outcometree.mli,v 1.11 2003/07/02 09:14:33 xleroy Exp $ *)
+(* $Id: outcometree.mli,v 1.12 2004/06/12 08:55:48 xleroy Exp $ *)
 
 (* Module [Outcometree]: results displayed by the toplevel *)
 
@@ -79,16 +79,22 @@ type out_module_type =
   | Omty_ident of out_ident
   | Omty_signature of out_sig_item list
 and out_sig_item =
-  | Osig_class of bool * string * string list * out_class_type
-  | Osig_class_type of bool * string * string list * out_class_type
+  | Osig_class of
+      bool * string * string list * out_class_type * out_rec_status
+  | Osig_class_type of
+      bool * string * string list * out_class_type * out_rec_status
   | Osig_exception of string * out_type list
   | Osig_modtype of string * out_module_type
-  | Osig_module of string * out_module_type
-  | Osig_type of out_type_decl list
+  | Osig_module of string * out_module_type * out_rec_status
+  | Osig_type of out_type_decl * out_rec_status
   | Osig_value of string * out_type * string list
 and out_type_decl =
   string * (string * (bool * bool)) list * out_type *
   (out_type * out_type) list
+and out_rec_status =
+  | Orec_not
+  | Orec_first
+  | Orec_next
 
 type out_phrase =
   | Ophr_eval of out_value * out_type
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index ce690d38..93004e3c 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parmatch.ml,v 1.61 2003/08/18 08:26:18 garrigue Exp $ *)
+(* $Id: parmatch.ml,v 1.65 2004/01/16 14:09:30 maranget Exp $ *)
 
 (* Detection of partial matches and unused match cases. *)
 
@@ -42,12 +42,11 @@ let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty
 
 (* p and q compatible means, there exists V that matches both *)
 
-let is_absent tag row =
-  let row = Btype.row_repr row in
-  let field =
-    try Btype.row_field_repr (List.assoc tag row.row_fields)
-    with Not_found -> Rabsent
-  in field = Rabsent
+let is_absent tag row = Btype.row_field tag row = Rabsent
+
+let is_absent_pat p = match p.pat_desc with
+| Tpat_variant (tag, _, row) -> is_absent tag row
+| _ -> false
 
 let sort_fields args =
   Sort.list
@@ -84,9 +83,9 @@ let rec compat p q =
   | Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) ->
       c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
   | Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) ->
-      l1=l2 && not (is_absent l1 r1) && compat p1 p2
+      l1=l2 && compat p1 p2
   | Tpat_variant (l1,None,r1), Tpat_variant(l2,None,_) ->
-      l1 = l2 && not (is_absent l1 r1)
+      l1 = l2 
   | Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false
   | Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false
   | Tpat_record l1,Tpat_record l2 ->
@@ -602,10 +601,11 @@ let full_match closing env =  match env with
         row.row_fields
     else
       row.row_closed &&
-      List.for_all
-        (fun (tag,f) ->
-          Btype.row_field_repr f = Rabsent || List.mem tag fields)
-        row.row_fields
+      let count =
+        List.fold_left
+          (fun n (_,f) -> if Btype.row_field_repr f = Rabsent then n else n+1)
+          0 row.row_fields in
+      List.length fields = count
 | ({pat_desc = Tpat_constant(Const_char _)},_) :: _ ->
     List.length env = 256
 | ({pat_desc = Tpat_constant(_)},_) :: _ -> false
@@ -826,11 +826,6 @@ let build_other env =  match env with
     Does there exists at least one value vector, es such that :
      1- for all ps in pss ps # es (ps and es are not compatible)
      2- qs <= es                  (es matches qs)
-  NOTE:
-   satisfiable assumes that any pattern has at least one
-   matching value (see first case)
-   quid of << absent >> variants ??
-
 *)
 
 let rec has_instance p = match p.pat_desc with
@@ -860,11 +855,14 @@ let rec satisfiable pss qs = match pss with
           (* first column of pss is made of variables only *)
         | [] -> satisfiable (filter_extra pss) qs
         | constrs  ->
-            (not (full_match false constrs) &&
-             satisfiable (filter_extra pss) qs) ||
-             List.exists
-               (fun (p,pss) -> satisfiable pss (simple_match_args p omega @ qs))
-               constrs
+            if full_match false constrs then
+              List.exists
+                (fun (p,pss) ->
+                  not (is_absent_pat p) &&
+                  satisfiable pss (simple_match_args p omega @ qs))
+                constrs
+            else
+              satisfiable (filter_extra pss) qs
         end
     | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
     | q::qs ->
@@ -960,13 +958,17 @@ let rec exhaust pss n = match pss with
       end
     | constrs ->          
         let try_non_omega (p,pss) =
-          match
-            exhaust pss (List.length (simple_match_args p omega) + n - 1)
-          with
-          | Rsome r -> Rsome (set_args p r)
-          | r       -> r in
+          if is_absent_pat p then
+            Rnone
+          else
+            match
+              exhaust pss (List.length (simple_match_args p omega) + n - 1)
+            with
+            | Rsome r -> Rsome (set_args p r)
+            | r       -> r in
         if full_match false constrs
-        then try_many try_non_omega constrs
+        then
+          try_many try_non_omega constrs
         else
           (*
              D = filter_extra pss is the default matrix
@@ -1308,11 +1310,8 @@ and every_both pss qs q1 q2 =
 let rec le_pat p q =
   match (p.pat_desc, q.pat_desc) with
   | (Tpat_var _|Tpat_any),_ -> true
-(* Absent variants have no instance *)
-  | _, Tpat_variant (l,_,row)  when is_absent l row -> true
   | Tpat_alias(p,_), _ -> le_pat p q
   | _, Tpat_alias(q,_) -> le_pat p q
-  | _, Tpat_or(q1,q2,_) -> le_pat p q1 && le_pat p q2
   | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
   | Tpat_construct(c1,ps), Tpat_construct(c2,qs) ->
       c1.cstr_tag = c2.cstr_tag && le_pats ps qs
@@ -1320,6 +1319,7 @@ let rec le_pat p q =
       (l1 = l2 && le_pat p1 p2)
   | Tpat_variant(l1,None,r1), Tpat_variant(l2,None,_) ->
       l1 = l2
+  | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
   | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
   | Tpat_record l1, Tpat_record l2 ->
       let ps,qs = records_args l1 l2 in
@@ -1327,9 +1327,7 @@ let rec le_pat p q =
   | Tpat_array(ps), Tpat_array(qs) ->
       List.length ps = List.length qs && le_pats ps qs
 (* In all other cases, enumeration is performed *)
-  | _,_  ->
-      not (satisfiable [[p]] [q])
-
+  | _,_  -> not (satisfiable [[p]] [q])
         
 and le_pats ps qs =
   match ps,qs with
@@ -1345,7 +1343,6 @@ let get_mins le ps =
         else select_rec (p::r) ps in
   select_rec [] (select_rec [] ps)
 
-
 (*
   lub p q is a pattern that matches all values matched by p and q
   may raise Empty, when p and q and not compatible
@@ -1367,11 +1364,11 @@ let rec lub p q = match p.pat_desc,q.pat_desc with
         let rs = lubs ps1 ps2 in
         make_pat (Tpat_construct (c1,rs)) p.pat_type p.pat_env
 | Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
-          when  l1=l2 && not (is_absent l1 row) ->
+          when  l1=l2 ->
             let r=lub p1 p2 in
             make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
 | Tpat_variant (l1,None,row), Tpat_variant(l2,None,_)
-              when l1 = l2 && not (is_absent l1 row) -> p
+              when l1 = l2 -> p
 | Tpat_record l1,Tpat_record l2 ->
     let rs = record_lubs l1 l2 in
     make_pat (Tpat_record rs) p.pat_type p.pat_env
@@ -1507,6 +1504,7 @@ let check_partial_all v casel =
   | NoGuard -> None
 
 let check_partial loc casel =
+  if Warnings.is_active (Warnings.Partial_match "") then begin
   let pss = initial_matrix casel in
   let pss = get_mins le_pats pss in
   match pss with
@@ -1554,6 +1552,8 @@ let check_partial loc casel =
       | _ ->
           fatal_error "Parmatch.check_partial"
       end
+  end else
+    Partial
 
 
 let location_of_clause = function
@@ -1587,7 +1587,8 @@ let check_unused tdefs casel =
       | (q,act as clause)::rem ->
           let qs = [q] in
             begin try
-              let pss = get_mins le_pats (List.filter (compats qs) pref) in
+              let pss =
+                  get_mins le_pats (List.filter (compats qs) pref) in
               let r = every_satisfiables (make_rows pss) (make_row qs) in
               match r with
               | Unused ->
diff --git a/typing/predef.ml b/typing/predef.ml
index 67cf49ec..a678e19f 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: predef.ml,v 1.28 2003/07/05 11:13:24 xleroy Exp $ *)
+(* $Id: predef.ml,v 1.29 2004/01/04 14:32:34 doligez Exp $ *)
 
 (* Predefined type constructors (with special typing rules in typecore) *)
 
@@ -66,18 +66,19 @@ and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
 and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
 and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
 
-let ident_match_failure = Ident.create "Match_failure"
-and ident_out_of_memory = Ident.create "Out_of_memory"
-and ident_invalid_argument = Ident.create "Invalid_argument"
-and ident_failure = Ident.create "Failure"
-and ident_not_found = Ident.create "Not_found"
-and ident_sys_error = Ident.create "Sys_error"
-and ident_end_of_file = Ident.create "End_of_file"
-and ident_division_by_zero = Ident.create "Division_by_zero"
-and ident_stack_overflow = Ident.create "Stack_overflow"
-and ident_sys_blocked_io = Ident.create "Sys_blocked_io"
-and ident_assert_failure = Ident.create "Assert_failure"
-and ident_undefined_recursive_module = Ident.create "Undefined_recursive_module"
+let ident_match_failure = Ident.create_predef_exn "Match_failure"
+and ident_out_of_memory = Ident.create_predef_exn "Out_of_memory"
+and ident_invalid_argument = Ident.create_predef_exn "Invalid_argument"
+and ident_failure = Ident.create_predef_exn "Failure"
+and ident_not_found = Ident.create_predef_exn "Not_found"
+and ident_sys_error = Ident.create_predef_exn "Sys_error"
+and ident_end_of_file = Ident.create_predef_exn "End_of_file"
+and ident_division_by_zero = Ident.create_predef_exn "Division_by_zero"
+and ident_stack_overflow = Ident.create_predef_exn "Stack_overflow"
+and ident_sys_blocked_io = Ident.create_predef_exn "Sys_blocked_io"
+and ident_assert_failure = Ident.create_predef_exn "Assert_failure"
+and ident_undefined_recursive_module =
+        Ident.create_predef_exn "Undefined_recursive_module"
 
 let path_match_failure = Pident ident_match_failure
 and path_assert_failure = Pident ident_assert_failure
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 899aac35..e40dedab 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printtyp.ml,v 1.125 2003/07/02 09:14:34 xleroy Exp $ *)
+(* $Id: printtyp.ml,v 1.130.2.1 2004/07/07 01:45:21 garrigue Exp $ *)
 
 (* Printing functions *)
 
@@ -24,16 +24,6 @@ open Types
 open Btype
 open Outcometree
 
-(* Redefine it here since goal differs *)
-
-let rec opened_object ty =
-  match (repr ty).desc with
-    Tobject (t, _)     -> opened_object t
-  | Tfield(_, _, _, t) -> opened_object t
-  | Tvar               -> true
-  | Tunivar            -> true
-  | _                  -> false
-
 (* Print a long identifier *)
 
 let rec longident ppf = function
@@ -69,6 +59,119 @@ let rec path ppf = function
   | Papply(p1, p2) ->
       fprintf ppf "%a(%a)" path p1 path p2
 
+(* Print a recursive annotation *)
+
+let tree_of_rec = function
+  | Trec_not -> Orec_not
+  | Trec_first -> Orec_first
+  | Trec_next -> Orec_next
+
+(* Print a raw type expression, with sharing *)
+
+let raw_list pr ppf = function
+    [] -> fprintf ppf "[]"
+  | a :: l ->
+      fprintf ppf "@[<1>[%a%t]@]" pr a
+        (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)
+
+let rec safe_kind_repr v = function
+    Fvar {contents=Some k}  ->
+      if List.memq k v then "Fvar loop" else
+      safe_kind_repr (k::v) k
+  | Fvar _ -> "Fvar None"
+  | Fpresent -> "Fpresent"
+  | Fabsent -> "Fabsent"
+
+let rec safe_commu_repr v = function
+    Cok -> "Cok"
+  | Cunknown -> "Cunknown"
+  | Clink r ->
+      if List.memq r v then "Clink loop" else
+      safe_commu_repr (r::v) !r
+
+let rec safe_repr v = function
+    {desc = Tlink t} when not (List.memq t v) ->
+      safe_repr (t::v) t
+  | t -> t
+
+let rec list_of_memo = function
+    Mnil -> []
+  | Mcons (p, t1, t2, rem) -> (p,t1,t2) :: list_of_memo rem
+  | Mlink rem -> list_of_memo !rem
+
+let visited = ref []
+let rec raw_type ppf ty =
+  let ty = safe_repr [] ty in
+  if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin
+    visited := ty :: !visited;
+    fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level
+      raw_type_desc ty.desc
+  end
+and raw_type_list tl = raw_list raw_type tl
+and raw_type_desc ppf = function
+    Tvar -> fprintf ppf "Tvar"
+  | Tarrow(l,t1,t2,c) ->
+      fprintf ppf "@[<hov1>Tarrow(%s,@,%a,@,%a,@,%s)@]"
+        l raw_type t1 raw_type t2
+        (safe_commu_repr [] c)
+  | Ttuple tl ->
+      fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
+  | Tconstr (p, tl, abbrev) ->
+      fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
+        raw_type_list tl
+        (raw_list (fun ppf (p,t1,t2) ->
+          fprintf ppf "@[%a,@ %a,@ %a@]" path p raw_type t1 raw_type t2))
+        (list_of_memo !abbrev)
+  | Tobject (t, nm) ->
+      fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
+        (fun ppf ->
+          match !nm with None -> fprintf ppf " None"
+          | Some(p,tl) ->
+              fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl)
+  | Tfield (f, k, t1, t2) ->
+      fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@,%a)@]" f
+        (safe_kind_repr [] k)
+        raw_type t1 raw_type t2
+  | Tnil -> fprintf ppf "Tnil"  
+  | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
+  | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
+  | Tunivar -> fprintf ppf "Tunivar"
+  | Tpoly (t, tl) ->
+      fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
+        raw_type t
+        raw_type_list tl
+  | Tvariant row ->
+      fprintf ppf
+        "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%b;@ %s%b;@ @[<1>%s%t@]}@]"
+        "row_fields="
+        (raw_list (fun ppf (l, f) ->
+          fprintf ppf "@[%s,@ %a@]" l raw_field f))
+        row.row_fields
+        "row_more=" raw_type row.row_more
+        "row_closed=" row.row_closed
+        "row_fixed=" row.row_fixed
+        "row_name="
+        (fun ppf ->
+          match row.row_name with None -> fprintf ppf "None"
+          | Some(p,tl) ->
+              fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl)
+
+and raw_field ppf = function
+    Rpresent None -> fprintf ppf "Rpresent None"
+  | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
+  | Reither (c,tl,m,e) ->
+      fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c
+        raw_type_list tl m
+        (fun ppf ->
+          match !e with None -> fprintf ppf " None"
+          | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
+  | Rabsent -> fprintf ppf "Rabsent"
+
+let raw_type_expr ppf t =
+  visited := [];
+  raw_type ppf t;
+  visited := []
+
 (* Print a type expression *)
 
 let names = ref ([] : (type_expr * string) list)
@@ -472,11 +575,11 @@ and tree_of_constructor (name, args) =
 and tree_of_label (name, mut, arg) =
   (name, mut = Mutable, tree_of_typexp false arg)
 
-let tree_of_type_declaration id decl =
-  Osig_type [tree_of_type_decl id decl]
+let tree_of_type_declaration id decl rs =
+  Osig_type (tree_of_type_decl id decl, tree_of_rec rs)
 
 let type_declaration id ppf decl =
-  !Oprint.out_sig_item ppf (tree_of_type_declaration id decl)
+  !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first)
 
 (* Print an exception declaration *)
 
@@ -508,31 +611,17 @@ let class_var sch ppf l (m, t) =
   fprintf ppf
     "@ @[<2>val %s%s :@ %a@]" (string_of_mutable m) l (typexp sch 0) t
 
-let metho sch concrete ppf (lab, kind, ty) =
-  if lab <> "*dummy method*" then begin
-    let priv =
-      match field_kind_repr kind with
-      | Fvar _ (* {contents = None} *) -> "private "
-      | _ (* Fpresent *) -> "" in
-    let virt =
-      if Concr.mem lab concrete then "" else "virtual " in
-    fprintf ppf "@ @[<2>method %s%s%s :@ %a@]" priv virt lab (typexp sch 0) ty
-  end
-
-let method_type ty =
-  let ty = repr ty in
-  match ty.desc with
-    Tpoly(ty, _) -> ty
-  | _            -> ty
+let method_type (_, kind, ty) =
+  match field_kind_repr kind, repr ty with
+    Fpresent, {desc=Tpoly(ty, _)} -> ty
+  | _       , ty                  -> ty
 
 let tree_of_metho sch concrete csil (lab, kind, ty) =
-  if lab <> "*dummy method*" then begin
-    let priv =
-      match field_kind_repr kind with
-      | Fvar _ (* {contents = None} *) -> true
-      | _ (* Fpresent *) -> false in
+  if lab <> dummy_method then begin
+    let kind = field_kind_repr kind in
+    let priv = kind <> Fpresent in
     let virt = not (Concr.mem lab concrete) in
-    let ty = method_type ty in
+    let ty = method_type (lab, kind, ty) in
     Ocsg_method (lab, priv, virt, tree_of_typexp sch ty) :: csil
   end
   else csil
@@ -554,7 +643,7 @@ let rec prepare_class_type params = function
       let (fields, _) =
         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
       in
-      List.iter (fun (_, _, ty) -> mark_loops (method_type ty)) fields;
+      List.iter (fun met -> mark_loops (method_type met)) fields;
       Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
   | Tcty_fun (_, ty, cty) ->
       mark_loops ty;
@@ -620,7 +709,7 @@ let tree_of_class_params = function
       let tyl = tree_of_typlist true params in
       List.map (function Otyp_var (_, s) -> s | _ -> "?") tyl
 
-let tree_of_class_declaration id cl =
+let tree_of_class_declaration id cl rs =
   let params = filter_params cl.cty_params in
 
   reset ();
@@ -635,12 +724,13 @@ let tree_of_class_declaration id cl =
   let vir_flag = cl.cty_new = None in
   Osig_class
     (vir_flag, Ident.name id, tree_of_class_params params,
-     tree_of_class_type true params cl.cty_type)
+     tree_of_class_type true params cl.cty_type,
+     tree_of_rec rs)
 
 let class_declaration id ppf cl =
-  !Oprint.out_sig_item ppf (tree_of_class_declaration id cl)
+  !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first)
 
-let tree_of_cltype_declaration id cl =
+let tree_of_cltype_declaration id cl rs =
   let params = List.map repr cl.clty_params in
 
   reset ();
@@ -659,15 +749,16 @@ let tree_of_cltype_declaration id cl =
       Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
     List.exists
       (fun (lab, _, ty) ->
-         not (lab = "*dummy method*" || Concr.mem lab sign.cty_concr))
+         not (lab = dummy_method || Concr.mem lab sign.cty_concr))
       fields in
 
   Osig_class_type
     (virt, Ident.name id, tree_of_class_params params,
-     tree_of_class_type true params cl.clty_type)
+     tree_of_class_type true params cl.clty_type,
+     tree_of_rec rs)
 
 let cltype_declaration id ppf cl =
-  !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl)
+  !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first)
 
 (* Print a module type *)
 
@@ -682,48 +773,25 @@ let rec tree_of_modtype = function
 
 and tree_of_signature = function
   | [] -> []
-  | item :: rem ->
-      match item with
-      | Tsig_value(id, decl) ->
-          tree_of_value_description id decl :: tree_of_signature rem
-      | Tsig_type(id, decl)  ->
-          let (type_decl_list, rem) =
-            let rec more_type_declarations = function
-            | Tsig_type(id, decl) :: rem ->
-                let (type_decl_list, rem) = more_type_declarations rem in
-                (id, decl) :: type_decl_list, rem
-            | rem -> [], rem in
-            more_type_declarations rem
-          in
-          let type_decl_list =
-            List.map (fun (id, decl) -> tree_of_type_decl id decl)
-              ((id, decl) :: type_decl_list)
-          in
-          Osig_type type_decl_list
-          ::
-          tree_of_signature rem
-      | Tsig_exception(id, decl)  ->
-          Osig_exception (Ident.name id, tree_of_typlist false decl) ::
-          tree_of_signature rem
-      | Tsig_module(id, mty)  ->
-          Osig_module (Ident.name id, tree_of_modtype mty) ::
-          tree_of_signature rem
-      | Tsig_modtype(id, decl)  ->
-          tree_of_modtype_declaration id decl :: tree_of_signature rem
-      | Tsig_class(id, decl) ->
-          let rem =
-            match rem with
-            | ctydecl :: tydecl1 :: tydecl2 :: rem -> rem
-            | _ -> []
-          in
-          tree_of_class_declaration id decl :: tree_of_signature rem
-      | Tsig_cltype(id, decl) ->
-          let rem =
-            match rem with
-            | tydecl1 :: tydecl2 :: rem -> rem
-            | _ -> []
-          in
-          tree_of_cltype_declaration id decl :: tree_of_signature rem
+  | Tsig_value(id, decl) :: rem ->
+      tree_of_value_description id decl :: tree_of_signature rem
+  | Tsig_type(id, decl, rs) :: rem ->
+      Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
+      tree_of_signature rem
+  | Tsig_exception(id, decl) :: rem ->
+      Osig_exception (Ident.name id, tree_of_typlist false decl) ::
+      tree_of_signature rem
+  | Tsig_module(id, mty, rs) :: rem ->
+      Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) ::
+      tree_of_signature rem
+  | Tsig_modtype(id, decl) :: rem ->
+      tree_of_modtype_declaration id decl :: tree_of_signature rem
+  | Tsig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem ->
+      tree_of_class_declaration id decl rs :: tree_of_signature rem
+  | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
+      tree_of_cltype_declaration id decl rs :: tree_of_signature rem
+  | _ ->
+      assert false
 
 and tree_of_modtype_declaration id decl =
   let mty =
@@ -733,7 +801,8 @@ and tree_of_modtype_declaration id decl =
   in
   Osig_modtype (Ident.name id, mty)
 
-let tree_of_module id mty = Osig_module (Ident.name id, tree_of_modtype mty)
+let tree_of_module id mty rs = 
+  Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs)
 
 let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty)
 let modtype_declaration id ppf decl =
@@ -762,11 +831,6 @@ let rec trace fst txt ppf = function
        (trace false txt) rem
   | _ -> ()
 
-let rec mismatch = function
-  | [(_, t); (_, t')] -> (t, t')
-  | _ :: _ :: rem -> mismatch rem
-  | _ -> assert false
-
 let rec filter_trace = function
   | (t1, t1') :: (t2, t2') :: rem ->
       let rem' = filter_trace rem in
@@ -789,12 +853,37 @@ let prepare_expansion (t, t') =
   mark_loops t; if t != t' then mark_loops t';
   (t, t')
 
+let may_prepare_expansion compact (t, t') =
+  match (repr t').desc with
+    Tvariant _ | Tobject _ when compact ->
+      mark_loops t; (t, t)
+  | _ -> prepare_expansion (t, t')
+
 let print_tags ppf fields =
   match fields with [] -> ()
   | (t, _) :: fields ->
       fprintf ppf "`%s" t;
       List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields
 
+let has_explanation unif t3 t4 =
+  match t3.desc, t4.desc with
+    Tfield _, _ | _, Tfield _
+  | Tunivar, Tvar | Tvar, Tunivar
+  | Tvariant _, Tvariant _ -> true
+  | Tconstr (p, _, _), Tvar | Tvar, Tconstr (p, _, _) ->
+      unif && min t3.level t4.level < Path.binding_time p
+  | _ -> false
+
+let rec mismatch unif = function
+    (_, t) :: (_, t') :: rem ->
+      begin match mismatch unif rem with
+        Some _ as m -> m
+      | None ->
+          if has_explanation unif t t' then Some(t,t') else None
+      end
+  | [] -> None
+  | _ -> assert false
+
 let explanation unif t3 t4 ppf =
   match t3.desc, t4.desc with
   | Tfield _, Tvar | Tvar, Tfield _ ->
@@ -812,10 +901,12 @@ let explanation unif t3 t4 ppf =
   | Tvar, Tunivar | Tunivar, Tvar ->
       fprintf ppf "@,The universal variable %a would escape its scope"
         type_expr (if t3.desc = Tunivar then t3 else t4)
-  | Tfield ("*dummy method*", _, _, _), _
-  | _, Tfield ("*dummy method*", _, _, _) ->
+  | Tfield (lab, _, _, _), _
+  | _, Tfield (lab, _, _, _) when lab = dummy_method ->
       fprintf ppf
         "@,Self type cannot be unified with a closed object type"
+  | Tfield (l, _, _, _), Tfield (l', _, _, _) when l = l' ->
+      fprintf ppf "@,Types for method %s are incompatible" l
   | Tfield (l, _, _, _), _ ->
       fprintf ppf
         "@,@[Only the first object type has a method %s@]" l
@@ -836,22 +927,29 @@ let explanation unif t3 t4 ppf =
           fprintf ppf
             "@,@[The second variant type does not allow tag(s)@ @[<hov>%a@]@]"
             print_tags fields
+      | [l1,_], true, [l2,_], true when l1 = l2 ->
+          fprintf ppf "@,Types for tag `%s are incompatible" l1
       | _ -> ()
       end
   | _ -> ()
 
+let explanation unif mis ppf =
+  match mis with
+    None -> ()
+  | Some (t3, t4) -> explanation unif t3 t4 ppf
+
 let unification_error unif tr txt1 ppf txt2 =
   reset ();
   let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
-  let (t3, t4) = mismatch tr in
+  let mis = mismatch unif tr in
   match tr with
   | [] | _ :: [] -> assert false
   | t1 :: t2 :: tr ->
     try
-      let t1, t1' = prepare_expansion t1
-      and t2, t2' = prepare_expansion t2 in
-      print_labels := not !Clflags.classic;
       let tr = filter_trace tr in
+      let t1, t1' = may_prepare_expansion (tr = []) t1
+      and t2, t2' = may_prepare_expansion (tr = []) t2 in
+      print_labels := not !Clflags.classic;
       let tr = List.map prepare_expansion tr in
       fprintf ppf
         "@[<v>\
@@ -862,7 +960,7 @@ let unification_error unif tr txt1 ppf txt2 =
         txt1 (type_expansion t1) t1'
         txt2 (type_expansion t2) t2'
         (trace false "is not compatible with type") tr
-        (explanation unif t3 t4);
+        (explanation unif mis);
       print_labels := true
     with exn ->
       print_labels := true;
@@ -889,6 +987,6 @@ let report_subtyping_error ppf tr1 txt1 tr2 =
   and tr2 = List.map prepare_expansion tr2 in
   trace true txt1 ppf tr1;
   if tr2 = [] then () else
-  let t3, t4 = mismatch tr2 in
+  let mis = mismatch true tr2 in
   trace false "is not compatible with type" ppf tr2;
-  explanation true t3 t4 ppf
+  explanation true mis ppf
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index 0d405565..7e42f642 100644
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printtyp.mli,v 1.24 2002/04/18 07:27:45 garrigue Exp $ *)
+(* $Id: printtyp.mli,v 1.26 2004/06/12 08:55:48 xleroy Exp $ *)
 
 (* Printing functions *)
 
@@ -22,6 +22,7 @@ val longident: formatter -> Longident.t -> unit
 val ident: formatter -> Ident.t -> unit
 val tree_of_path: Path.t -> out_ident
 val path: formatter -> Path.t -> unit
+val raw_type_expr: formatter -> type_expr -> unit
 val reset: unit -> unit
 val mark_loops: type_expr -> unit
 val reset_and_mark_loops: type_expr -> unit
@@ -36,19 +37,19 @@ val type_scheme_max: ?b_reset_names: bool ->
 (* Fin Maxence *)
 val tree_of_value_description: Ident.t -> value_description -> out_sig_item
 val value_description: Ident.t -> formatter -> value_description -> unit
-val tree_of_type_declaration: Ident.t -> type_declaration -> out_sig_item
+val tree_of_type_declaration: Ident.t -> type_declaration -> rec_status -> out_sig_item
 val type_declaration: Ident.t -> formatter -> type_declaration -> unit
 val tree_of_exception_declaration: Ident.t -> exception_declaration -> out_sig_item
 val exception_declaration: Ident.t -> formatter -> exception_declaration -> unit
-val tree_of_module: Ident.t -> module_type -> out_sig_item
+val tree_of_module: Ident.t -> module_type -> rec_status -> out_sig_item
 val modtype: formatter -> module_type -> unit
 val signature: formatter -> signature -> unit
 val tree_of_modtype_declaration: Ident.t -> modtype_declaration -> out_sig_item
 val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
 val class_type: formatter -> class_type -> unit
-val tree_of_class_declaration: Ident.t -> class_declaration -> out_sig_item
+val tree_of_class_declaration: Ident.t -> class_declaration -> rec_status -> out_sig_item
 val class_declaration: Ident.t -> formatter -> class_declaration -> unit
-val tree_of_cltype_declaration: Ident.t -> cltype_declaration -> out_sig_item
+val tree_of_cltype_declaration: Ident.t -> cltype_declaration -> rec_status -> out_sig_item
 val cltype_declaration: Ident.t -> formatter -> cltype_declaration -> unit
 val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
 val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
diff --git a/typing/subst.ml b/typing/subst.ml
index 8f497d6b..721c5d0e 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: subst.ml,v 1.44 2003/07/22 10:58:39 garrigue Exp $ *)
+(* $Id: subst.ml,v 1.46 2004/06/12 08:55:48 xleroy Exp $ *)
 
 (* Substitutions *)
 
@@ -183,7 +183,11 @@ let type_declaration s decl =
 let class_signature s sign =
   { cty_self = typexp s sign.cty_self;
     cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars;
-    cty_concr = sign.cty_concr }
+    cty_concr = sign.cty_concr;
+    cty_inher =
+      List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
+        sign.cty_inher
+  }
 
 let rec class_type s =
   function
@@ -233,10 +237,10 @@ let exception_declaration s tyl =
 
 let rec rename_bound_idents s idents = function
     [] -> (List.rev idents, s)
-  | Tsig_type(id, d) :: sg ->
+  | Tsig_type(id, d, _) :: sg ->
       let id' = Ident.rename id in
       rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
-  | Tsig_module(id, mty) :: sg ->
+  | Tsig_module(id, mty, _) :: sg ->
       let id' = Ident.rename id in
       rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg
   | Tsig_modtype(id, d) :: sg ->
@@ -244,7 +248,7 @@ let rec rename_bound_idents s idents = function
       rename_bound_idents (add_modtype id (Tmty_ident(Pident id')) s)
                           (id' :: idents) sg
   | (Tsig_value(id, _) | Tsig_exception(id, _) | 
-     Tsig_class(id, _) | Tsig_cltype(id, _)) :: sg ->
+     Tsig_class(id, _, _) | Tsig_cltype(id, _, _)) :: sg ->
       let id' = Ident.rename id in
       rename_bound_idents s (id' :: idents) sg
 
@@ -277,18 +281,18 @@ and signature_component s comp newid =
   match comp with
     Tsig_value(id, d) ->
       Tsig_value(newid, value_description s d)
-  | Tsig_type(id, d) ->
-      Tsig_type(newid, type_declaration s d)
+  | Tsig_type(id, d, rs) ->
+      Tsig_type(newid, type_declaration s d, rs)
   | Tsig_exception(id, d) ->
       Tsig_exception(newid, exception_declaration s d)
-  | Tsig_module(id, mty) ->
-      Tsig_module(newid, modtype s mty)
+  | Tsig_module(id, mty, rs) ->
+      Tsig_module(newid, modtype s mty, rs)
   | Tsig_modtype(id, d) ->
       Tsig_modtype(newid, modtype_declaration s d)
-  | Tsig_class(id, d) ->
-      Tsig_class(newid, class_declaration s d)
-  | Tsig_cltype(id, d) ->
-      Tsig_cltype(newid, cltype_declaration s d)
+  | Tsig_class(id, d, rs) ->
+      Tsig_class(newid, class_declaration s d, rs)
+  | Tsig_cltype(id, d, rs) ->
+      Tsig_cltype(newid, cltype_declaration s d, rs)
 
 and modtype_declaration s = function
     Tmodtype_abstract -> Tmodtype_abstract
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index c2a318bd..3d7d69cd 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* typeclass.ml,v 1.57.4.6 2002/02/15 14:26:04 garrigue Exp *)
+(* $Id: typeclass.ml,v 1.78 2004/05/31 02:01:59 garrigue Exp $ *)
 
 open Misc
 open Parsetree
@@ -48,6 +48,7 @@ type error =
   | Cannot_coerce_self of type_expr
   | Non_collapsable_conjunction of
       Ident.t * Types.class_declaration * (type_expr * type_expr) list
+  | Final_self_clash of (type_expr * type_expr) list
 
 exception Error of Location.t * error
 
@@ -61,7 +62,7 @@ exception Error of Location.t * error
    Self type have a dummy private method, thus preventing it to become
    closed.
 *)
-let dummy_method = "*dummy method*"
+let dummy_method = Ctype.dummy_method
 
 (*
    Path associated to the temporary class type of a class being typed
@@ -87,16 +88,16 @@ let rec generalize_class_type =
     Tcty_constr (_, params, cty) ->
       List.iter Ctype.generalize params;
       generalize_class_type cty
-  | Tcty_signature {cty_self = sty; cty_vars = vars } ->
+  | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
       Ctype.generalize sty;
-      Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars
+      Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars;
+      List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
   | Tcty_fun (_, ty, cty) ->
       Ctype.generalize ty;
       generalize_class_type cty
 
 (* Return the virtual methods of a class type *)
-let virtual_methods cty =
-  let sign = Ctype.signature_of_class_type cty in
+let virtual_methods sign =
   let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
   List.fold_left
     (fun virt (lab, _, _) ->
@@ -172,7 +173,9 @@ let rec limited_generalize rv =
   | Tcty_signature sign ->
       Ctype.limited_generalize rv sign.cty_self;
       Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
-        sign.cty_vars
+        sign.cty_vars;
+      List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+        sign.cty_inher
   | Tcty_fun (_, ty, cty) ->
       Ctype.limited_generalize rv ty;
       limited_generalize rv cty
@@ -247,8 +250,8 @@ let declare_method val_env meths self_type lab priv sty loc =
      Ctype.filter_self_method val_env lab priv meths self_type
   in
   let ty =
-    match sty.ptyp_desc with
-      Ptyp_poly ([],sty) -> transl_simple_type_univars val_env sty
+    match sty.ptyp_desc, priv with
+      Ptyp_poly ([],sty), Public -> transl_simple_type_univars val_env sty
     | _                  -> transl_simple_type val_env false sty
   in
   begin try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
@@ -272,10 +275,15 @@ let make_method cl_num expr =
 
 (*******************************)
 
-let rec class_type_field env self_type meths (val_sig, concr_meths) =
+let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
   function
     Pctf_inher sparent ->
       let parent = class_type env sparent in
+      let inher =
+        match parent with
+          Tcty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
       let (cl_sig, concr_meths, _) =
         inheritance self_type env concr_meths Concr.empty sparent.pcty_loc
           parent
@@ -285,7 +293,7 @@ let rec class_type_field env self_type meths (val_sig, concr_meths) =
           (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
           cl_sig.cty_vars val_sig
       in
-      (val_sig, concr_meths)
+      (val_sig, concr_meths, inher)
 
   | Pctf_val (lab, mut, sty_opt, loc) ->
       let (mut, ty) =
@@ -299,19 +307,19 @@ let rec class_type_field env self_type meths (val_sig, concr_meths) =
         | Some sty ->
             mut, transl_simple_type env false sty
       in
-      (Vars.add lab (mut, ty) val_sig, concr_meths)
+      (Vars.add lab (mut, ty) val_sig, concr_meths, inher)
 
   | Pctf_virt (lab, priv, sty, loc) ->
       declare_method env meths self_type lab priv sty loc;
-      (val_sig, concr_meths)
+      (val_sig, concr_meths, inher)
 
   | Pctf_meth (lab, priv, sty, loc)  ->
       declare_method env meths self_type lab priv sty loc;
-      (val_sig, Concr.add lab concr_meths)
+      (val_sig, Concr.add lab concr_meths, inher)
 
   | Pctf_cstr (sty, sty', loc) ->
       type_constraint env sty sty' loc;
-      (val_sig, concr_meths)
+      (val_sig, concr_meths, inher)
 
 and class_signature env sty sign =
   let meths = ref Meths.empty in
@@ -328,15 +336,16 @@ and class_signature env sty sign =
   end;
   
   (* Class type fields *)
-  let (val_sig, concr_meths) =
+  let (val_sig, concr_meths, inher) =
     List.fold_left (class_type_field env self_type meths)
-      (Vars.empty, Concr.empty)
+      (Vars.empty, Concr.empty, [])
       sign
   in
   
   {cty_self = self_type;
    cty_vars = val_sig;
-   cty_concr = concr_meths }
+   cty_concr = concr_meths;
+   cty_inher = inher}
 
 and class_type env scty =
   match scty.pcty_desc with
@@ -376,10 +385,16 @@ and class_type env scty =
 module StringSet = Set.Make(struct type t = string let compare = compare end)
 
 let rec class_field cl_num self_type meths vars
-    (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals) =
+    (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+     inh_vals, inher) =
   function
     Pcf_inher (sparent, super) ->
       let parent = class_expr cl_num val_env par_env sparent in
+      let inher =
+        match parent.cl_type with
+          Tcty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
       let (cl_sig, concr_meths, warn_meths) =
         inheritance self_type val_env concr_meths warn_meths sparent.pcl_loc
           parent.cl_type
@@ -417,7 +432,7 @@ let rec class_field cl_num self_type meths vars
       in
       (val_env, met_env, par_env,
        lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
-       concr_meths, warn_meths, inh_vals)
+       concr_meths, warn_meths, inh_vals, inher)
 
   | Pcf_val (lab, mut, sexp, loc) ->
       if StringSet.mem lab inh_vals then
@@ -435,12 +450,13 @@ let rec class_field cl_num self_type meths vars
         enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
       in
       (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
-       concr_meths, warn_meths, inh_vals)
+       concr_meths, warn_meths, inh_vals, inher)
 
   | Pcf_virt (lab, priv, sty, loc) ->
       virtual_method val_env meths self_type lab priv sty loc;
       let warn_meths = Concr.remove lab warn_meths in
-      (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
+      (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+       inh_vals, inher)
 
   | Pcf_meth (lab, priv, expr, loc)  ->
       let (_, ty) =
@@ -469,6 +485,7 @@ let rec class_field cl_num self_type meths vars
         raise(Error(loc, Method_type_mismatch (lab, trace)))
       end;
       let meth_expr = make_method cl_num expr in
+      (* backup variables for Pexp_override *)
       let vars_local = !vars in
 
       let field =
@@ -482,11 +499,12 @@ let rec class_field cl_num self_type meths vars
           Cf_meth (lab, texp)
         end in
       (val_env, met_env, par_env, field::fields,
-       Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals)
+       Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher)
 
   | Pcf_cstr (sty, sty', loc) ->
       type_constraint val_env sty sty' loc;
-      (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
+      (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+       inh_vals, inher)
 
   | Pcf_let (rec_flag, sdefs, loc) ->
       let (defs, val_env) =
@@ -516,7 +534,7 @@ let rec class_field cl_num self_type meths vars
           ([], met_env, par_env)
       in
       (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
-       concr_meths, warn_meths, inh_vals)
+       concr_meths, warn_meths, inh_vals, inher)
 
   | Pcf_init expr ->
       let expr = make_method cl_num expr in
@@ -533,53 +551,116 @@ let rec class_field cl_num self_type meths vars
           Cf_init texp
         end in
       (val_env, met_env, par_env, field::fields,
-       concr_meths, warn_meths, inh_vals)
+       concr_meths, warn_meths, inh_vals, inher)
 
-and class_structure cl_num val_env met_env (spat, str) =
+and class_structure cl_num final val_env met_env loc (spat, str) =
   (* Environment for substructures *)
   let par_env = met_env in
 
+  (* Self type, with a dummy method preventing it from being closed/escaped. *)
+  let self_type = Ctype.newvar () in
+  Ctype.unify val_env
+    (Ctype.filter_method val_env dummy_method Private self_type)
+    (Ctype.newty (Ttuple []));
+
+  (* Private self is used for private method calls *)
+  let private_self = if final then Ctype.newvar () else self_type in
+
   (* Self binder *)
   let (pat, meths, vars, val_env, meth_env, par_env) =
-    type_self_pattern cl_num val_env met_env par_env spat
+    type_self_pattern cl_num private_self val_env met_env par_env spat
   in
-  let self_type = pat.pat_type in
+  let public_self = pat.pat_type in
 
-  (* Check that the binder has a correct type, and introduce a dummy
-     method preventing self type from being closed. *)
-  let ty = Ctype.newvar () in
-  Ctype.unify val_env
-      (Ctype.filter_method val_env dummy_method Private ty)
-      (Ctype.newty (Ttuple []));
-  begin try Ctype.unify val_env self_type ty with
+  (* Check that the binder has a correct type *)
+  let ty =
+    if final then Ctype.newty (Tobject (Ctype.newvar(), ref None))
+    else self_type in
+  begin try Ctype.unify val_env public_self ty with
     Ctype.Unify _ ->
-      raise(Error(spat.ppat_loc, Pattern_type_clash self_type))
+      raise(Error(spat.ppat_loc, Pattern_type_clash public_self))
+  end;
+  let get_methods ty =
+    (fst (Ctype.flatten_fields
+            (Ctype.object_fields (Ctype.expand_head val_env ty)))) in
+  if final then begin
+    (* Copy known information to still empty self_type *)
+    List.iter
+      (fun (lab,kind,ty) ->
+        let k =
+          if Btype.field_kind_repr kind = Fpresent then Public else Private in
+        try Ctype.unify val_env ty
+            (Ctype.filter_method val_env lab k self_type)
+        with _ -> assert false)
+      (get_methods public_self)
   end;
 
-  (* Class fields *)
-  let (_, _, _, fields, concr_meths, _, _) =
+  (* Typing of class fields *)
+  let (_, _, _, fields, concr_meths, _, _, inher) =
     List.fold_left (class_field cl_num self_type meths vars)
       (val_env, meth_env, par_env, [], Concr.empty, Concr.empty,
-       StringSet.empty)
+       StringSet.empty, [])
       str
   in
   Ctype.unify val_env self_type (Ctype.newvar ());
-  let methods =
-    if !Clflags.principal then
-      fst (Ctype.flatten_fields (Ctype.object_fields self_type))
-    else [] in
-  List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
-  let vars_final = !vars in
-  let fields = List.map Lazy.force (List.rev fields) in
-  vars := vars_final;
-  List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) methods;
-
-  {cl_field = fields;
-   cl_meths = Meths.map (function (id, ty) -> id) !meths},
+  let sign =
+    {cty_self = public_self;
+     cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
+     cty_concr = concr_meths;
+     cty_inher = inher} in
+  let methods = get_methods self_type in
+  let priv_meths =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
+      methods in
+  if final then begin
+    (* Unify private_self and a copy of self_type. self_type will not
+       be modified after this point *)
+    Ctype.close_object self_type;
+    let mets = virtual_methods {sign with cty_self = self_type} in
+    if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
+    let self_methods =
+      List.fold_right
+        (fun (lab,kind,ty) rem ->
+          if lab = dummy_method then
+            (* allow public self and private self to be unified *)
+            match Btype.field_kind_repr kind with
+              Fvar r -> Btype.set_kind r Fabsent; rem
+            | _ -> rem
+          else
+            Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
+        methods (Ctype.newty Tnil) in
+    begin try
+      Ctype.unify val_env private_self
+        (Ctype.newty (Tobject(self_methods, ref None)));
+      Ctype.unify val_env public_self self_type
+    with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace))
+    end;
+  end;
 
-  {cty_self = self_type;
-   cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
-   cty_concr = concr_meths }
+  (* Typing of method bodies *)
+  if !Clflags.principal then
+    List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
+  let fields = List.map Lazy.force (List.rev fields) in
+  if !Clflags.principal then
+    List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ()))
+      methods;
+  let meths = Meths.map (function (id, ty) -> id) !meths in
+
+  (* Check for private methods made public *)
+  let pub_meths' =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
+      (get_methods public_self) in
+  let names = List.map (fun (x,_,_) -> x) in
+  let l1 = names priv_meths and l2 = names pub_meths' in
+  let added = List.filter (fun x -> List.mem x l1) l2 in
+  if added <> [] then
+    Location.prerr_warning loc
+      (Warnings.Other
+         (String.concat " "
+            ("the following private methods were made public implicitly:\n "
+             :: added)));
+
+  {cl_field = fields; cl_meths = meths}, sign
 
 and class_expr cl_num val_env met_env scl =
   match scl.pcl_desc with
@@ -610,17 +691,21 @@ and class_expr cl_num val_env met_env scl =
       let cl =        
         rc {cl_desc = Tclass_ident path;
             cl_loc = scl.pcl_loc;
-            cl_type = clty'}
+            cl_type = clty';
+            cl_env = val_env}
       in
       let (vals, meths, concrs) = extract_constraints clty in
       rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
           cl_loc = scl.pcl_loc;
-          cl_type = clty'}
+          cl_type = clty';
+          cl_env = val_env}
   | Pcl_structure cl_str ->
-      let (desc, ty) = class_structure cl_num val_env met_env cl_str in
+      let (desc, ty) =
+        class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
       rc {cl_desc = Tclass_structure desc;
           cl_loc = scl.pcl_loc;
-          cl_type = Tcty_signature ty}
+          cl_type = Tcty_signature ty;
+          cl_env = val_env}
   | Pcl_fun (l, Some default, spat, sbody) ->
       let loc = default.pexp_loc in
       let scases =
@@ -682,7 +767,8 @@ and class_expr cl_num val_env met_env scl =
           (Warnings.Other "This optional argument cannot be erased");
       rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
           cl_loc = scl.pcl_loc;
-          cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type)}
+          cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type);
+          cl_env = val_env}
   | Pcl_apply (scl', sargs) ->
       let cl = class_expr cl_num val_env met_env scl' in
       let rec nonopt_labels ls ty_fun =
@@ -769,7 +855,8 @@ and class_expr cl_num val_env met_env scl =
       in
       rc {cl_desc = Tclass_apply (cl, args);
           cl_loc = scl.pcl_loc;
-          cl_type = cty}
+          cl_type = cty;
+          cl_env = val_env}
   | Pcl_let (rec_flag, sdefs, scl') ->
       let (defs, val_env) =
         try
@@ -802,7 +889,8 @@ and class_expr cl_num val_env met_env scl =
       let cl = class_expr cl_num val_env met_env scl' in
       rc {cl_desc = Tclass_let (rec_flag, defs, vals, cl);
           cl_loc = scl.pcl_loc;
-          cl_type = cl.cl_type}
+          cl_type = cl.cl_type;
+          cl_env = val_env}
   | Pcl_constraint (scl', scty) ->
       Ctype.begin_class_def ();
       let context = Typetexp.narrow () in
@@ -824,7 +912,8 @@ and class_expr cl_num val_env met_env scl =
       let (vals, meths, concrs) = extract_constraints clty in
       rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
           cl_loc = scl.pcl_loc;
-          cl_type = snd (Ctype.instance_class [] clty)}
+          cl_type = snd (Ctype.instance_class [] clty);
+          cl_env = val_env}
 
 (*******************************)
 
@@ -888,7 +977,8 @@ let rec initial_env define_class approx
     Tcty_signature
       { cty_self = Ctype.newvar ();
         cty_vars = Vars.empty;
-        cty_concr = Concr.empty }
+        cty_concr = Concr.empty;
+        cty_inher = [] }
   in
   let dummy_class =
     {cty_params = [];             (* Dummy value *)
@@ -1034,7 +1124,7 @@ let class_infos define_class kind
   in
 
   if cl.pci_virt = Concrete then begin
-    match virtual_methods typ with
+    match virtual_methods (Ctype.signature_of_class_type typ) with
       []   -> ()
     | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
   end;
@@ -1149,10 +1239,13 @@ let merge_type_decls
 let final_env define_class env
     (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
      arity, pub_meths, coe, expr) =
-  Env.add_type obj_id obj_abbr (
-  Env.add_type cl_id cl_abbr (
-  Env.add_cltype ty_id cltydef (
-  if define_class then Env.add_class id clty env else env)))
+  (* Add definitions after cleaning them *)
+  Env.add_type obj_id (Subst.type_declaration Subst.identity obj_abbr) (
+  Env.add_type cl_id (Subst.type_declaration Subst.identity cl_abbr) (
+  Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
+  if define_class then
+    Env.add_class id (Subst.class_declaration Subst.identity clty) env
+  else env)))
 
 (* Check that #c is coercible to c if there is a self-coercion *)
 let check_coercions env
@@ -1237,6 +1330,40 @@ let class_type_declarations env cls =
      decl,
    env)
 
+let rec unify_parents env ty cl =
+  match cl.cl_desc with
+    Tclass_ident p ->
+      begin try
+        let decl = Env.find_class p env in
+        let _, body = Ctype.find_cltype_for_path env decl.cty_path in
+        Ctype.unify env ty (Ctype.instance body)
+      with exn -> assert (exn = Not_found)
+      end
+  | Tclass_structure st -> unify_parents_struct env ty st
+  | Tclass_fun (_, _, cl, _)
+  | Tclass_apply (cl, _)
+  | Tclass_let (_, _, _, cl)
+  | Tclass_constraint (cl, _, _, _) -> unify_parents env ty cl
+and unify_parents_struct env ty st =
+  List.iter
+    (function Cf_inher (cl, _, _) -> unify_parents env ty cl
+      | _ -> ())
+    st.cl_field
+
+let type_object env loc s =
+  incr class_num;
+  let (desc, sign) =
+    class_structure (string_of_int !class_num) true env env loc s in
+  let sty = Ctype.expand_head env sign.cty_self in
+  Ctype.hide_private_methods sty;
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  let meths = List.map (fun (s,_,_) -> s) fields in
+  unify_parents_struct env sign.cty_self desc;
+  (desc, sign, meths)
+
+let () =
+  Typecore.type_object := type_object
+
 (*******************************)
 
 (* Approximate the class declaration as class ['params] id = object end *)
@@ -1318,9 +1445,9 @@ let report_error ppf = function
   | Virtual_class (cl, mets) ->
       let print_mets ppf mets =
         List.iter (function met -> fprintf ppf "@ %s" met) mets in
-      let cl_mark = if cl then " type" else "" in
+      let cl_mark = if cl then "" else " type" in
       fprintf ppf
-        "@[This class %s should be virtual@ \
+        "@[This class%s should be virtual@ \
            @[<2>The following methods are undefined :%a@]
          @]"
         cl_mark print_mets mets
@@ -1390,3 +1517,9 @@ let report_error ppf = function
       Printtyp.report_unification_error ppf trace
         (fun ppf -> fprintf ppf "Type")
         (fun ppf -> fprintf ppf "is not compatible with type")
+  | Final_self_clash trace ->
+      Printtyp.report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "This object is expected to have type")
+        (function ppf ->
+           fprintf ppf "but has actually type")
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index 1abe431d..81760965 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typeclass.mli,v 1.16 2003/06/19 15:53:53 xleroy Exp $ *)
+(* $Id: typeclass.mli,v 1.18 2003/12/01 00:32:11 garrigue Exp $ *)
 
 open Asttypes
 open Types
@@ -45,6 +45,8 @@ val approx_class_declarations:
    Ident.t * type_declaration *
    Ident.t * type_declaration) list
 
+val virtual_methods: Types.class_signature -> label list
+
 type error =
     Unconsistent_constraint of (type_expr * type_expr) list
   | Method_type_mismatch of string * (type_expr * type_expr) list
@@ -71,6 +73,7 @@ type error =
   | Cannot_coerce_self of type_expr
   | Non_collapsable_conjunction of
       Ident.t * Types.class_declaration * (type_expr * type_expr) list
+  | Final_self_clash of (type_expr * type_expr) list
 
 exception Error of Location.t * error
 
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 8608c3dc..4a76e3c0 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typecore.ml,v 1.154 2003/08/25 00:41:24 garrigue Exp $ *)
+(* $Id: typecore.ml,v 1.160.2.1 2004/06/21 20:36:20 weis Exp $ *)
 
 (* Typechecking for the core language *)
 
@@ -67,6 +67,11 @@ let type_module =
   ref ((fun env md -> assert false) :
        Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
 
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+let type_object =
+  ref (fun env s -> assert false :
+       Env.t -> Location.t -> Parsetree.class_structure ->
+	 class_structure * class_signature * string list)
 
 (*
   Saving and outputting type information.
@@ -147,10 +152,7 @@ let finalize_variant pat =
   match pat.pat_desc with
     Tpat_variant(tag, opat, row) ->
       let row = row_repr row in
-      let field =
-        try row_field_repr (List.assoc tag row.row_fields)
-        with Not_found -> Rabsent
-      in
+      let field = row_field tag row in
       begin match field with
       | Rabsent -> assert false
       | Reither (true, [], _, e) when not row.row_closed ->
@@ -252,11 +254,12 @@ let rec build_as_type env p =
   | Tpat_record lpl ->
       let lbl = fst(List.hd lpl) in
       let ty = newvar () in
+      let ppl = List.map (fun (l,p) -> l.lbl_pos, p) lpl in
       let do_label lbl =
         let _, ty_arg, ty_res = instance_label false lbl in
         unify_pat env {p with pat_type = ty} ty_res;
-        if lbl.lbl_mut = Immutable && List.mem_assoc lbl lpl then begin
-          let arg = List.assoc lbl lpl in
+        if lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl then begin
+          let arg = List.assoc lbl.lbl_pos ppl in
           unify_pat env {arg with pat_type = build_as_type env arg} ty_arg
         end else begin
           let _, ty_arg', ty_res' = instance_label false lbl in
@@ -332,6 +335,22 @@ let build_or_pat env loc lid =
           pat pats in
       rp { r with pat_loc = loc }
 
+let rec find_record_qual = function
+  | [] -> None
+  | (Longident.Ldot (modname, _), _) :: _ -> Some modname
+  | _ :: rest -> find_record_qual rest
+
+let type_label_a_list type_lid_a lid_a_list =
+  match find_record_qual lid_a_list with
+  | None -> List.map type_lid_a lid_a_list
+  | Some modname ->
+      List.map
+        (function
+         | (Longident.Lident id), sarg ->
+              type_lid_a (Longident.Ldot (modname, id), sarg)
+         | lid_a -> type_lid_a lid_a)
+        lid_a_list
+
 let rec type_pat env sp =
   match sp.ppat_desc with
     Ppat_any ->
@@ -439,7 +458,7 @@ let rec type_pat env sp =
         (label, arg)
       in
       rp {
-        pat_desc = Tpat_record(List.map type_label_pat lid_sp_list);
+        pat_desc = Tpat_record(type_label_a_list type_label_pat lid_sp_list);
         pat_loc = sp.ppat_loc;
         pat_type = ty;
         pat_env = env }
@@ -522,7 +541,8 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
   (pat, pv, val_env, met_env)
 
 let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
-let type_self_pattern cl_num val_env met_env par_env spat =
+
+let type_self_pattern cl_num privty val_env met_env par_env spat =
   let spat = 
     mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
                        "selfpat-" ^ cl_num))
@@ -539,7 +559,7 @@ let type_self_pattern cl_num val_env met_env par_env spat =
       (fun (id, ty) (val_env, met_env, par_env) ->
          (Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
           Env.add_value id {val_type = ty;
-                            val_kind = Val_self (meths, vars, cl_num)}
+                            val_kind = Val_self (meths, vars, cl_num, privty)}
             met_env,
           Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env))
       pv (val_env, met_env, par_env)
@@ -582,7 +602,20 @@ let rec is_nonexpansive exp =
       is_nonexpansive ifso && is_nonexpansive_opt ifnot
   | Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
       true
-  | Texp_lazy e -> true
+  (* Note: nonexpansive only means no _observable_ side effects *)
+  | Texp_lazy e -> is_nonexpansive e
+  | Texp_object ({cl_field=fields}, {cty_vars=vars}, _) ->
+      let count = ref 0 in
+      List.for_all
+        (function
+            Cf_meth _ -> true
+          | Cf_val (_,_,e) -> incr count; is_nonexpansive e
+          | Cf_init e -> is_nonexpansive e
+          | Cf_inher _ | Cf_let _ -> false)
+        fields &&
+      Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
+        vars true &&
+      !count = 0
   | _ -> false
 
 and is_nonexpansive_opt = function
@@ -594,12 +627,15 @@ and is_nonexpansive_opt = function
 
 let type_format loc fmt =
   let len = String.length fmt in
-  let ty_input = newvar()
-  and ty_result = newvar()
+  let ty_input = newvar ()
+  and ty_result = newvar ()
   and ty_aresult = newvar () in
-  let ty_arrow gty ty = newty (Tarrow("", instance gty, ty, Cok)) in
-  let incomplete i =
-    raise (Error (loc, Bad_format (String.sub fmt i (len - i)))) in
+  let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in
+
+  let invalid_fmt s = raise (Error (loc, Bad_format s)) in
+  let incomplete i = invalid_fmt (String.sub fmt i (len - i)) in
+  let invalid i j = invalid_fmt (String.sub fmt i (j - i + 1)) in
+
   let rec scan_format i =
     if i >= len then ty_aresult, ty_result else
     match fmt.[i] with
@@ -660,8 +696,7 @@ let type_format loc fmt =
       | '%' | '!' -> scan_format (j + 1)
       | 's' | 'S' | '[' -> conversion j Predef.type_string
       | 'c' | 'C' -> conversion j Predef.type_char
-      | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
-          conversion j Predef.type_int
+      | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' -> conversion j Predef.type_int
       | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
       | 'B' | 'b' -> conversion j Predef.type_bool
       | 'a' ->
@@ -670,24 +705,24 @@ let type_format loc fmt =
           let ty_aresult, ty_result = conversion j ty_arg in
           ty_aresult, ty_arrow ty_a ty_result
       | 't' -> conversion j (ty_arrow ty_input ty_aresult)
-      | 'n' when j + 1 = len -> conversion j Predef.type_int
-      | 'l' | 'n' | 'L' as conv ->
+      | 'n' | 'l' when j + 1 = len -> conversion j Predef.type_int
+      | 'n' | 'l' | 'L' as c ->
           let j = j + 1 in
           if j >= len then incomplete i else begin
-            match fmt.[j] with
-            | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
-                let ty_arg =
-                 match conv with
-                 | 'l' -> Predef.type_int32
-                 | 'n' -> Predef.type_nativeint
-                 | _ -> Predef.type_int64 in
-                conversion j ty_arg
-            | c ->
-               if conv = 'n' then conversion (j - 1) Predef.type_int else
-               raise(Error(loc, Bad_format(String.sub fmt i (j - i))))
+          match fmt.[j] with
+          | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+             let ty_arg =
+               match c with
+               | 'l' -> Predef.type_int32
+               | 'n' -> Predef.type_nativeint
+               | _ -> Predef.type_int64 in
+              conversion j ty_arg
+          | _ ->
+             if c = 'l' || c = 'n'
+             then conversion (j - 1) Predef.type_int
+             else invalid i (j - 1)
           end
-      | c ->
-          raise(Error(loc, Bad_format(String.sub fmt i (j - i + 1)))) in
+      | c -> invalid i j in
     scan_width i j in
 
   let ty_ares, ty_res = scan_format 0 in
@@ -795,7 +830,7 @@ let rec type_exp env sexp =
                   Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
                 in
                 Texp_instvar(self_path, path)
-            | Val_self (_, _, cl_num) ->
+            | Val_self (_, _, cl_num, _) ->
                 let (path, _) =
                   Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
                 in
@@ -915,7 +950,7 @@ let rec type_exp env sexp =
         if label.lbl_private = Private then
           raise(Error(sexp.pexp_loc, Private_type ty));
         (label, {arg with exp_type = instance arg.exp_type}) in
-      let lbl_exp_list = List.map type_label_exp lid_sexp_list in
+      let lbl_exp_list = type_label_a_list type_label_exp lid_sexp_list in
       let rec check_duplicates seen_pos lid_sexp lbl_exp =
         match (lid_sexp, lbl_exp) with
           ((lid, _) :: rem1, (lbl, _) :: rem2) ->
@@ -1122,9 +1157,9 @@ let rec type_exp env sexp =
       begin try
         let (exp, typ) =
           match obj.exp_desc with
-            Texp_ident(path, {val_kind = Val_self (meths, _, _)}) ->
+            Texp_ident(path, {val_kind = Val_self (meths, _, _, privty)}) ->
               let (id, typ) =
-                filter_self_method env met Private meths obj.exp_type
+                filter_self_method env met Private meths privty
               in
               (Texp_send(obj, Tmeth_val id), typ)
           | Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) ->
@@ -1137,10 +1172,10 @@ let rec type_exp env sexp =
                 Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env,
                 Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env
               with
-                (_, ({val_kind = Val_self (meths, _, _)} as desc)),
+                (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
                 (path, _) ->
                   let (_, typ) =
-                    filter_self_method env met Private meths obj.exp_type
+                    filter_self_method env met Private meths privty
                   in
                   let method_type = newvar () in
                   let (obj_ty, res_ty) = filter_arrow env method_type "" in
@@ -1250,7 +1285,7 @@ let rec type_exp env sexp =
         with Not_found ->
           raise(Error(sexp.pexp_loc, Outside_class))
       with
-        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _)}),
+        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
         (path_self, _) ->
           let type_override (lab, snewval) =
             begin try
@@ -1317,6 +1352,14 @@ let rec type_exp env sexp =
          exp_type = instance (Predef.type_lazy_t arg.exp_type);
          exp_env = env;
        }
+  | Pexp_object s ->
+      let desc, sign, meths = !type_object env sexp.pexp_loc s in
+      re {
+        exp_desc = Texp_object (desc, sign, meths);
+        exp_loc = sexp.pexp_loc;
+        exp_type = sign.cty_self;
+        exp_env = env;
+      }
   | Pexp_poly _ ->
       assert false
 
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 9cd7a90d..ec11a9e3 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typecore.mli,v 1.34 2003/07/02 09:14:34 xleroy Exp $ *)
+(* $Id: typecore.mli,v 1.35 2003/11/25 09:20:42 garrigue Exp $ *)
 
 (* Type inference for the core language *)
 
@@ -35,7 +35,7 @@ val type_class_arg_pattern:
         Typedtree.pattern * (Ident.t * Ident.t * type_expr) list *
         Env.t * Env.t
 val type_self_pattern:
-        string -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
+        string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
         Typedtree.pattern *
         (Ident.t * type_expr) Meths.t ref *
         (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
@@ -102,3 +102,7 @@ val report_error: formatter -> error -> unit
 
 (* Forward declaration, to be filled in by Typemod.type_module *)
 val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+val type_object:
+  (Env.t -> Location.t -> Parsetree.class_structure ->
+   Typedtree.class_structure * class_signature * string list) ref
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 90321ea5..86a212e6 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typedecl.ml,v 1.66 2003/07/03 14:35:35 xleroy Exp $ *)
+(* $Id: typedecl.ml,v 1.67 2003/11/07 00:19:08 garrigue Exp $ *)
 
 (**** Typing of type definitions ****)
 
@@ -309,12 +309,14 @@ let check_recursion env loc path decl to_check =
           else if to_check path' && not (List.mem path' prev_exp) then begin
             try
               (* Attempt expansion *)
-              let (params, body) = Env.find_type_expansion path' env in
+              let (params0, body0) = Env.find_type_expansion path' env in
               let (params, body) = 
-                Ctype.instance_parameterized_type params body in
+                Ctype.instance_parameterized_type params0 body0 in
               begin
                 try List.iter2 (Ctype.unify env) params args'
-                with Ctype.Unify _ -> assert false
+                with Ctype.Unify _ ->
+                  raise (Error(loc, Constraint_failed
+                                 (ty, Ctype.newconstr path' params0)));
               end;
               check_regular path' args (path' :: prev_exp) body
             with Not_found -> ()
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 2161fd11..18d400c9 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typedtree.ml,v 1.35 2003/08/12 03:11:38 garrigue Exp $ *)
+(* $Id: typedtree.ml,v 1.36 2003/11/25 09:20:43 garrigue Exp $ *)
 
 (* Abstract syntax tree after typing *)
 
@@ -77,6 +77,7 @@ and expression_desc =
   | Texp_assert of expression
   | Texp_assertfalse
   | Texp_lazy of expression
+  | Texp_object of class_structure * class_signature * string list
 
 and meth =
     Tmeth_name of string
@@ -87,7 +88,8 @@ and meth =
 and class_expr =
   { cl_desc: class_expr_desc;
     cl_loc: Location.t;
-    cl_type: class_type }
+    cl_type: class_type;
+    cl_env: Env.t }
 
 and class_expr_desc =
     Tclass_ident of Path.t
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index c3eb97d7..334a7392 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typedtree.mli,v 1.33 2003/08/12 03:11:38 garrigue Exp $ *)
+(* $Id: typedtree.mli,v 1.34 2003/11/25 09:20:43 garrigue Exp $ *)
 
 (* Abstract syntax tree after typing *)
 
@@ -76,6 +76,7 @@ and expression_desc =
   | Texp_assert of expression
   | Texp_assertfalse
   | Texp_lazy of expression
+  | Texp_object of class_structure * class_signature * string list
 
 and meth =
     Tmeth_name of string
@@ -86,7 +87,8 @@ and meth =
 and class_expr =
   { cl_desc: class_expr_desc;
     cl_loc: Location.t;
-    cl_type: class_type }
+    cl_type: class_type;
+    cl_env: Env.t }
 
 and class_expr_desc =
     Tclass_ident of Path.t
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 7b9f1d2c..a85eb4a1 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typemod.ml,v 1.65 2003/08/20 14:35:14 xleroy Exp $ *)
+(* $Id: typemod.ml,v 1.69 2004/06/13 12:48:01 xleroy Exp $ *)
 
 (* Type-checking of the module language *)
 
@@ -36,6 +36,8 @@ type error =
   | Non_generalizable of type_expr
   | Non_generalizable_class of Ident.t * class_declaration
   | Non_generalizable_module of module_type
+  | Implementation_is_required of string
+  | Interface_not_compiled of string
 
 exception Error of Location.t * error
 
@@ -71,20 +73,21 @@ let merge_constraint initial_env loc sg lid constr =
     match (sg, namelist, constr) with
       ([], _, _) ->
         raise(Error(loc, With_no_component lid))
-    | (Tsig_type(id, decl) :: rem, [s], Pwith_type sdecl)
+    | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl)
       when Ident.name id = s ->
         let newdecl = Typedecl.transl_with_constraint initial_env sdecl in
         Includemod.type_declarations env id newdecl decl;
-        Tsig_type(id, newdecl) :: rem
-    | (Tsig_module(id, mty) :: rem, [s], Pwith_module lid)
+        Tsig_type(id, newdecl, rs) :: rem
+    | (Tsig_module(id, mty, rs) :: rem, [s], Pwith_module lid)
       when Ident.name id = s ->
         let (path, mty') = type_module_path initial_env loc lid in
         let newmty = Mtype.strengthen env mty' path in
         ignore(Includemod.modtypes env newmty mty);
-        Tsig_module(id, newmty) :: rem
-    | (Tsig_module(id, mty) :: rem, s :: namelist, _) when Ident.name id = s ->
+        Tsig_module(id, newmty, rs) :: rem
+    | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _)
+      when Ident.name id = s ->
         let newsg = merge env (extract_sig env loc mty) namelist in
-        Tsig_module(id, Tmty_signature newsg) :: rem
+        Tsig_module(id, Tmty_signature newsg, rs) :: rem
     | (item :: rem, _, _) ->
         item :: merge (Env.add_item item env) rem namelist in
   try
@@ -92,6 +95,14 @@ let merge_constraint initial_env loc sg lid constr =
   with Includemod.Error explanation ->
     raise(Error(loc, With_mismatch(lid, explanation)))
 
+(* Add recursion flags on declarations arising from a mutually recursive
+   block. *)
+
+let map_rec fn decls rem =
+  match decls with
+  | [] -> rem
+  | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
+
 (* Auxiliary for translating recursively-defined module types.
    Return a module type that approximates the shape of the given module
    type AST.  Retain only module, type, and module type
@@ -127,11 +138,11 @@ let approx_modtype transl_mty init_env smty =
         | Psig_type sdecls ->
             let decls = Typedecl.approx_type_decl env sdecls in
             let rem = approx_sig env srem in
-            map_end (fun (id, info) -> Tsig_type(id, info)) decls rem
+            map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
         | Psig_module(name, smty) ->
             let mty = approx_mty env smty in
             let (id, newenv) = Env.enter_module name mty env in
-            Tsig_module(id, mty) :: approx_sig newenv srem
+            Tsig_module(id, mty, Trec_not) :: approx_sig newenv srem
         | Psig_recmodule sdecls ->
             let decls =
               List.map
@@ -141,7 +152,7 @@ let approx_modtype transl_mty init_env smty =
             let newenv =
               List.fold_left (fun env (id, mty) -> Env.add_module id mty env)
               env decls in
-            map_end (fun (id, mty) -> Tsig_module(id, mty)) decls
+            map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls
                     (approx_sig newenv srem)
         | Psig_modtype(name, sinfo) ->
             let info = approx_mty_info env sinfo in
@@ -162,11 +173,12 @@ let approx_modtype transl_mty init_env smty =
             let decls = Typeclass.approx_class_declarations env sdecls in
             let rem = approx_sig env srem in
             List.flatten
-              (List.map
-                (fun (i1, d1, i2, d2, i3, d3) ->
-                  [Tsig_cltype(i1, d1); Tsig_type(i2, d2); Tsig_type(i3, d3)])
-                decls)
-            @ rem
+              (map_rec
+                (fun rs (i1, d1, i2, d2, i3, d3) ->
+                  [Tsig_cltype(i1, d1, rs);
+                   Tsig_type(i2, d2, rs);
+                   Tsig_type(i3, d3, rs)])
+                decls [rem])
         | _ ->
             approx_sig env srem
 
@@ -203,9 +215,9 @@ let check cl loc set_ref name =
   else set_ref := StringSet.add name !set_ref
 
 let check_sig_item type_names module_names modtype_names loc = function
-    Tsig_type(id, _) ->
+    Tsig_type(id, _, _) ->
       check "type" loc type_names (Ident.name id)
-  | Tsig_module(id, _) ->
+  | Tsig_module(id, _, _) ->
       check "module" loc module_names (Ident.name id)
   | Tsig_modtype(id, _) ->
       check "module type" loc modtype_names (Ident.name id)
@@ -237,7 +249,7 @@ let rec transl_modtype env smty =
           (fun sg (lid, sdecl) ->
             merge_constraint env smty.pmty_loc sg lid sdecl)
           init_sg constraints in
-      Tmty_signature final_sg
+      Mtype.freshen (Tmty_signature final_sg)
       
 and transl_signature env sg =
   let type_names = ref StringSet.empty
@@ -260,7 +272,7 @@ and transl_signature env sg =
               sdecls;
             let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
             let rem = transl_sig newenv srem in
-            map_end (fun (id, info) -> Tsig_type(id, info)) decls rem
+            map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
         | Psig_exception(name, sarg) ->
             let arg = Typedecl.transl_exception env sarg in
             let (id, newenv) = Env.enter_exception name arg env in
@@ -271,7 +283,7 @@ and transl_signature env sg =
             let mty = transl_modtype env smty in
             let (id, newenv) = Env.enter_module name mty env in
             let rem = transl_sig newenv srem in
-            Tsig_module(id, mty) :: rem
+            Tsig_module(id, mty, Trec_not) :: rem
         | Psig_recmodule sdecls ->
             List.iter
               (fun (name, smty) ->
@@ -280,7 +292,7 @@ and transl_signature env sg =
             let (decls, newenv) =
               transl_recmodule_modtypes item.psig_loc env sdecls in
             let rem = transl_sig newenv srem in
-            map_end (fun (id, mty) -> Tsig_module(id, mty)) decls rem
+            map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls rem
         | Psig_modtype(name, sinfo) ->
             check "module type" item.psig_loc modtype_names name;
             let info = transl_modtype_info env sinfo in
@@ -311,10 +323,12 @@ and transl_signature env sg =
             let (classes, newenv) = Typeclass.class_descriptions env cl in
             let rem = transl_sig newenv srem in
             List.flatten
-              (map_end
-                 (fun (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
-                    [Tsig_class(i, d);    Tsig_cltype(i', d');
-                     Tsig_type(i'', d''); Tsig_type(i''', d''')])
+              (map_rec
+                 (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
+                    [Tsig_class(i, d, rs);
+                     Tsig_cltype(i', d', rs);
+                     Tsig_type(i'', d'', rs);
+                     Tsig_type(i''', d''', rs)])
                  classes [rem])
         | Psig_class_type cl ->
             List.iter
@@ -324,10 +338,11 @@ and transl_signature env sg =
             let (classes, newenv) = Typeclass.class_type_declarations env cl in
             let rem = transl_sig newenv srem in
             List.flatten
-              (map_end
-                 (fun (i, d, i', d', i'', d'') ->
-                    [Tsig_cltype(i, d);
-                     Tsig_type(i', d'); Tsig_type(i'', d'')])
+              (map_rec
+                 (fun rs (i, d, i', d', i'', d'') ->
+                    [Tsig_cltype(i, d, rs);
+                     Tsig_type(i', d', rs);
+                     Tsig_type(i'', d'', rs)])
                  classes [rem])
     in transl_sig env sg
 
@@ -378,7 +393,7 @@ let rec closed_modtype = function
 
 and closed_signature_item = function
     Tsig_value(id, desc) -> Ctype.closed_schema desc.val_type
-  | Tsig_module(id, mty) -> closed_modtype mty
+  | Tsig_module(id, mty, _) -> closed_modtype mty
   | _ -> true
 
 let check_nongen_scheme env = function
@@ -406,8 +421,8 @@ let rec bound_value_identifiers = function
   | Tsig_value(id, {val_kind = Val_reg}) :: rem ->
       id :: bound_value_identifiers rem
   | Tsig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem
-  | Tsig_module(id, mty) :: rem -> id :: bound_value_identifiers rem
-  | Tsig_class(id, decl) :: rem -> id :: bound_value_identifiers rem
+  | Tsig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
+  | Tsig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
   | _ :: rem -> bound_value_identifiers rem
 
 (* Helpers for typing recursive modules *)
@@ -539,7 +554,7 @@ and type_structure anchor env sstr =
           enrich_type_decls anchor decls env newenv in
         let (str_rem, sig_rem, final_env) = type_struct newenv' srem in
         (Tstr_type decls :: str_rem,
-         map_end (fun (id, info) -> Tsig_type(id, info)) decls sig_rem,
+         map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem,
          final_env)
     | {pstr_desc = Pstr_exception(name, sarg)} :: srem ->
         let arg = Typedecl.transl_exception env sarg in
@@ -562,7 +577,7 @@ and type_structure anchor env sstr =
         let (id, newenv) = Env.enter_module name mty env in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_module(id, modl) :: str_rem,
-         Tsig_module(id, modl.mod_type) :: sig_rem,
+         Tsig_module(id, modl.mod_type, Trec_not) :: sig_rem,
          final_env)
     | {pstr_desc = Pstr_recmodule sbind; pstr_loc = loc} :: srem ->
         List.iter
@@ -590,7 +605,7 @@ and type_structure anchor env sstr =
         let bind = List.map2 type_recmodule_binding decls sbind in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_recmodule bind :: str_rem,
-         map_end (fun (id, modl) -> Tsig_module(id, modl.mod_type))
+         map_rec (fun rs (id, modl) -> Tsig_module(id, modl.mod_type, rs))
                  bind sig_rem,
          final_env)
     | {pstr_desc = Pstr_modtype(name, smty); pstr_loc = loc} :: srem ->
@@ -622,10 +637,12 @@ and type_structure anchor env sstr =
            (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) ::
          str_rem,
          List.flatten
-           (map_end
-              (fun (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
-                 [Tsig_class(i, d);    Tsig_cltype(i', d');
-                  Tsig_type(i'', d''); Tsig_type(i''', d''')])
+           (map_rec
+              (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
+                 [Tsig_class(i, d, rs);
+                  Tsig_cltype(i', d', rs);
+                  Tsig_type(i'', d'', rs);
+                  Tsig_type(i''', d''', rs)])
               classes [sig_rem]),
          final_env)
     | {pstr_desc = Pstr_class_type cl; pstr_loc = loc} :: srem ->
@@ -642,9 +659,11 @@ and type_structure anchor env sstr =
            (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) ::
          str_rem,
          List.flatten
-           (map_end
-              (fun (i, d, i', d', i'', d'') ->
-                 [Tsig_cltype(i, d); Tsig_type(i', d'); Tsig_type(i'', d'')])
+           (map_rec
+              (fun rs (i, d, i', d', i'', d'') ->
+                 [Tsig_cltype(i, d, rs);
+                  Tsig_type(i', d', rs);
+                  Tsig_type(i'', d'', rs)])
               classes [sig_rem]),
          final_env)
     | {pstr_desc = Pstr_include smodl; pstr_loc = loc} :: srem ->
@@ -682,7 +701,7 @@ and normalize_signature env = List.iter (normalize_signature_item env)
 
 and normalize_signature_item env = function
     Tsig_value(id, desc) -> Ctype.normalize_type env desc.val_type
-  | Tsig_module(id, mty) -> normalize_modtype env mty
+  | Tsig_module(id, mty, _) -> normalize_modtype env mty
   | _ -> ()
 
 (* Simplify multiple specifications of a value or an exception in a signature.
@@ -709,9 +728,9 @@ and simplify_signature sg =
       simplif val_names (StringSet.add name exn_names)
               (if StringSet.mem name exn_names then res else component :: res)
               sg
-  | Tsig_module(id, mty) :: sg ->
+  | Tsig_module(id, mty, rs) :: sg ->
       simplif val_names exn_names
-              (Tsig_module(id, simplify_modtype mty) :: res) sg
+              (Tsig_module(id, simplify_modtype mty, rs) :: res) sg
   | component :: sg ->
       simplif val_names exn_names (component :: res) sg
   in
@@ -719,11 +738,11 @@ and simplify_signature sg =
 
 (* Typecheck an implementation file *)
 
-let type_implementation sourcefile prefixname modulename initial_env ast =
+let type_implementation sourcefile outputprefix modulename initial_env ast =
   Typecore.reset_delayed_checks ();
   let (str, sg, finalenv) =
     Misc.try_finally (fun () -> type_structure initial_env ast)
-                     (fun () -> Stypes.dump (prefixname ^ ".annot"))
+                     (fun () -> Stypes.dump (outputprefix ^ ".annot"))
   in
   Typecore.force_delayed_checks ();
   if !Clflags.print_types then begin
@@ -731,17 +750,21 @@ let type_implementation sourcefile prefixname modulename initial_env ast =
     (str, Tcoerce_none)
   end else begin
     let coercion =
-      if Sys.file_exists (prefixname ^ !Config.interface_suffix) then begin
+      let sourceintf =
+        Misc.chop_extension_if_any sourcefile ^ !Config.interface_suffix in
+      if Sys.file_exists sourceintf then begin
         let intf_file =
-          try find_in_path !Config.load_path (prefixname ^ ".cmi")
-          with Not_found -> prefixname ^ ".cmi" in
+          try
+            find_in_path_uncap !Config.load_path (modulename ^ ".cmi")
+          with Not_found ->
+            raise(Error(Location.none, Interface_not_compiled sourceintf)) in
         let dclsig = Env.read_signature modulename intf_file in
         Includemod.compunit sourcefile sg intf_file dclsig
       end else begin
         check_nongen_schemes finalenv str;
         normalize_signature finalenv sg;
         if not !Clflags.dont_write_files then
-          Env.save_signature sg modulename (prefixname ^ ".cmi");
+          Env.save_signature sg modulename (outputprefix ^ ".cmi");
         Tcoerce_none
       end in
     (str, coercion)
@@ -756,7 +779,7 @@ let rec package_signatures subst = function
       let sg' = Subst.signature subst sg in
       let oldid = Ident.create_persistent name
       and newid = Ident.create name in
-      Tsig_module(newid, Tmty_signature sg') ::
+      Tsig_module(newid, Tmty_signature sg', Trec_not) ::
       package_signatures (Subst.add_module oldid (Pident newid) subst) rem
 
 let package_units objfiles cmifile modulename =
@@ -766,6 +789,10 @@ let package_units objfiles cmifile modulename =
       (fun f ->
          let pref = chop_extension_if_any f in
          let modname = String.capitalize(Filename.basename pref) in
+         let sg = Env.read_signature modname (pref ^ ".cmi") in
+         if Filename.check_suffix f ".cmi" &&
+            not(Mtype.no_code_needed_sig Env.initial sg)
+         then raise(Error(Location.none, Implementation_is_required f));
          (modname, Env.read_signature modname (pref ^ ".cmi")))
       objfiles in
   (* Compute signature of packaged unit *)
@@ -840,3 +867,10 @@ let report_error ppf = function
       fprintf ppf
         "@[The type of this module,@ %a,@ \
            contains type variables that cannot be generalized@]" modtype mty
+  | Implementation_is_required intf_name ->
+      fprintf ppf
+        "@[The interface %s@ declares values, not just types.@ \
+           An implementation must be provided.@]" intf_name
+  | Interface_not_compiled intf_name ->
+      fprintf ppf
+        "@[Could not find the .cmi file for interface@ %s.@]" intf_name
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 607c3299..e412ac0d 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typemod.mli,v 1.22 2003/03/06 15:59:55 xleroy Exp $ *)
+(* $Id: typemod.mli,v 1.24 2004/06/13 12:48:01 xleroy Exp $ *)
 
 (* Type-checking of the module language *)
 
@@ -48,6 +48,8 @@ type error =
   | Non_generalizable of type_expr
   | Non_generalizable_class of Ident.t * class_declaration
   | Non_generalizable_module of module_type
+  | Implementation_is_required of string
+  | Interface_not_compiled of string
 
 exception Error of Location.t * error
 
diff --git a/typing/types.ml b/typing/types.ml
index 4a27e759..ab65b11f 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: types.ml,v 1.21 2003/07/02 09:14:35 xleroy Exp $ *)
+(* $Id: types.ml,v 1.24 2004/06/12 08:55:49 xleroy Exp $ *)
 
 (* Representation of types and declarations *)
 
@@ -91,7 +91,7 @@ and value_kind =
   | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
   | Val_self of (Ident.t * type_expr) Meths.t ref *
                 (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-                string
+                string * type_expr
                                         (* Self *)
   | Val_anc of (string * Ident.t) list * string
                                         (* Ancestor *)
@@ -157,7 +157,8 @@ type class_type =
 and class_signature =
   { cty_self: type_expr;
     cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
-    cty_concr: Concr.t }
+    cty_concr: Concr.t;
+    cty_inher: (Path.t * type_expr list) list }
 
 type class_declaration =
   { cty_params: type_expr list;
@@ -181,13 +182,18 @@ and signature = signature_item list
 
 and signature_item =
     Tsig_value of Ident.t * value_description
-  | Tsig_type of Ident.t * type_declaration
+  | Tsig_type of Ident.t * type_declaration * rec_status
   | Tsig_exception of Ident.t * exception_declaration
-  | Tsig_module of Ident.t * module_type
+  | Tsig_module of Ident.t * module_type * rec_status
   | Tsig_modtype of Ident.t * modtype_declaration
-  | Tsig_class of Ident.t * class_declaration
-  | Tsig_cltype of Ident.t * cltype_declaration
+  | Tsig_class of Ident.t * class_declaration * rec_status
+  | Tsig_cltype of Ident.t * cltype_declaration * rec_status
 
 and modtype_declaration =
     Tmodtype_abstract
   | Tmodtype_manifest of module_type
+
+and rec_status =
+    Trec_not
+  | Trec_first
+  | Trec_next
diff --git a/typing/types.mli b/typing/types.mli
index 6645f899..0bf96f4c 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: types.mli,v 1.21 2003/07/02 09:14:35 xleroy Exp $ *)
+(* $Id: types.mli,v 1.24 2004/06/12 08:55:49 xleroy Exp $ *)
 
 (* Representation of types and declarations *)
 
@@ -92,7 +92,7 @@ and value_kind =
   | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
   | Val_self of (Ident.t * type_expr) Meths.t ref *
                 (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-                string
+                string * type_expr
                                         (* Self *)
   | Val_anc of (string * Ident.t) list * string
                                         (* Ancestor *)
@@ -159,7 +159,8 @@ type class_type =
 and class_signature =
   { cty_self: type_expr;
     cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
-    cty_concr: Concr.t }
+    cty_concr: Concr.t;
+    cty_inher: (Path.t * type_expr list) list }
 
 type class_declaration =
   { cty_params: type_expr list;
@@ -183,13 +184,18 @@ and signature = signature_item list
 
 and signature_item =
     Tsig_value of Ident.t * value_description
-  | Tsig_type of Ident.t * type_declaration
+  | Tsig_type of Ident.t * type_declaration * rec_status
   | Tsig_exception of Ident.t * exception_declaration
-  | Tsig_module of Ident.t * module_type
+  | Tsig_module of Ident.t * module_type * rec_status
   | Tsig_modtype of Ident.t * modtype_declaration
-  | Tsig_class of Ident.t * class_declaration
-  | Tsig_cltype of Ident.t * cltype_declaration
+  | Tsig_class of Ident.t * class_declaration * rec_status
+  | Tsig_cltype of Ident.t * cltype_declaration * rec_status
 
 and modtype_declaration =
     Tmodtype_abstract
   | Tmodtype_manifest of module_type
+
+and rec_status =
+    Trec_not                            (* not recursive *)
+  | Trec_first                          (* first in a recursive group *)
+  | Trec_next                           (* not first in a recursive group *)
diff --git a/utils/ccomp.ml b/utils/ccomp.ml
index f12ebe5f..1a6801c1 100644
--- a/utils/ccomp.ml
+++ b/utils/ccomp.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ccomp.ml,v 1.16 2003/03/24 15:27:27 xleroy Exp $ *)
+(* $Id: ccomp.ml,v 1.17 2004/06/16 16:58:46 doligez Exp $ *)
 
 (* Compiling C files and building C libraries *)
 
@@ -25,7 +25,7 @@ let command cmdline =
 let run_command cmdline = ignore(command cmdline)
 
 (* Build @responsefile to work around Windows limitations on 
-   command-length line *)
+   command-line length *)
 let build_diversion lst =
   let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in
   List.iter
diff --git a/utils/config.mlp b/utils/config.mlp
index 5917795a..fbb045f7 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: config.mlp,v 1.194 2003/07/03 15:13:23 xleroy Exp $ *)
+(* $Id: config.mlp,v 1.196 2004/06/12 08:55:49 xleroy Exp $ *)
 
 (* The main OCaml version string has moved to stdlib/sys.ml *)
 let version = Sys.ocaml_version
@@ -39,12 +39,12 @@ let binutils_nm = "%%BINUTILS_NM%%"
 let binutils_objcopy = "%%BINUTILS_OBJCOPY%%"
 let cc_profile = "%%CC_PROFILE%%"
 
-let exec_magic_number = "Caml1999X007"
-and cmi_magic_number = "Caml1999I009"
-and cmo_magic_number = "Caml1999O005"
-and cma_magic_number = "Caml1999A006"
-and cmx_magic_number = "Caml1999Y008"
-and cmxa_magic_number = "Caml1999Z009"
+let exec_magic_number = "Caml1999X008"
+and cmi_magic_number = "Caml1999I010"
+and cmo_magic_number = "Caml1999O006"
+and cma_magic_number = "Caml1999A007"
+and cmx_magic_number = "Caml1999Y009"
+and cmxa_magic_number = "Caml1999Z010"
 and ast_impl_magic_number = "Caml1999M010"
 and ast_intf_magic_number = "Caml1999N009"
 
diff --git a/utils/misc.ml b/utils/misc.ml
index cbeb937b..da86f37d 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: misc.ml,v 1.32 2003/04/02 01:32:09 doligez Exp $ *)
+(* $Id: misc.ml,v 1.33.2.1 2004/07/07 16:47:27 xleroy Exp $ *)
 
 (* Errors *)
 
@@ -61,6 +61,12 @@ let rec split_last = function
       let (lst, last) = split_last tl in
       (hd :: lst, last)
 
+let rec samelist pred l1 l2 =
+  match (l1, l2) with
+  | ([], []) -> true
+  | (hd1 :: tl1, hd2 :: tl2) -> pred hd1 hd2 && samelist pred tl1 tl2
+  | (_, _) -> false
+
 (* Options *)
 
 let may f = function
@@ -154,10 +160,7 @@ let no_overflow_lsl a = min_int asr 1 <= a && a <= max_int asr 1
 (* String operations *)
 
 let chop_extension_if_any fname =
-  try
-    ignore(String.index (Filename.basename fname) '.');
-    Filename.chop_extension fname
-  with Not_found -> fname
+  try Filename.chop_extension fname with Invalid_argument _ -> fname
 
 let search_substring pat str start =
   let rec search i j =
diff --git a/utils/misc.mli b/utils/misc.mli
index b985e067..9a287560 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: misc.mli,v 1.24 2003/04/02 01:32:09 doligez Exp $ *)
+(* $Id: misc.mli,v 1.24.6.1 2004/07/07 16:47:27 xleroy Exp $ *)
 
 (* Miscellaneous useful types and functions *)
 
@@ -35,6 +35,9 @@ val list_remove: 'a -> 'a list -> 'a list
            element equal to [x] removed. *)
 val split_last: 'a list -> 'a list * 'a
         (* Return the last element and the other elements of the given list. *)
+val samelist: ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
+        (* Like [List.for_all2] but returns [false] if the two
+           lists have different length. *)
 
 val may: ('a -> unit) -> 'a option -> unit
 val may_map: ('a -> 'b) -> 'a option -> 'b option
diff --git a/utils/terminfo.ml b/utils/terminfo.ml
index cc7053e2..d2f98312 100644
--- a/utils/terminfo.ml
+++ b/utils/terminfo.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: terminfo.ml,v 1.5 1999/11/17 18:59:02 xleroy Exp $ *)
+(* $Id: terminfo.ml,v 1.6 2004/01/01 16:42:42 doligez Exp $ *)
 
 (* Basic interface to the terminfo database *)
 
@@ -19,7 +19,7 @@ type status =
   | Bad_term
   | Good_term of int
 ;;
-external setup : out_channel -> status = "terminfo_setup";;
-external backup : int -> unit = "terminfo_backup";;
-external standout : bool -> unit = "terminfo_standout";;
-external resume : int -> unit = "terminfo_resume";;
+external setup : out_channel -> status = "caml_terminfo_setup";;
+external backup : int -> unit = "caml_terminfo_backup";;
+external standout : bool -> unit = "caml_terminfo_standout";;
+external resume : int -> unit = "caml_terminfo_resume";;
diff --git a/utils/terminfo.mli b/utils/terminfo.mli
index e24b2904..d8a07651 100644
--- a/utils/terminfo.mli
+++ b/utils/terminfo.mli
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: terminfo.mli,v 1.6 1999/11/17 18:59:03 xleroy Exp $ *)
+(* $Id: terminfo.mli,v 1.7 2004/01/01 16:42:43 doligez Exp $ *)
 
 (* Basic interface to the terminfo database *)
 
@@ -19,7 +19,7 @@ type status =
   | Bad_term
   | Good_term of int  (* number of lines of the terminal *)
 ;;
-external setup : out_channel -> status = "terminfo_setup";;
-external backup : int -> unit = "terminfo_backup";;
-external standout : bool -> unit = "terminfo_standout";;
-external resume : int -> unit = "terminfo_resume";;
+external setup : out_channel -> status = "caml_terminfo_setup";;
+external backup : int -> unit = "caml_terminfo_backup";;
+external standout : bool -> unit = "caml_terminfo_standout";;
+external resume : int -> unit = "caml_terminfo_resume";;
diff --git a/win32caml/Makefile b/win32caml/Makefile
index 73655769..e7392f91 100644
--- a/win32caml/Makefile
+++ b/win32caml/Makefile
@@ -11,14 +11,15 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile,v 1.8 2003/08/29 14:30:15 xleroy Exp $
+# $Id: Makefile,v 1.9 2004/06/17 07:33:44 xleroy Exp $
 
 include ../config/Makefile
 
 CC=$(BYTECC)
 CFLAGS=$(BYTECCCOMPOPTS)
 
-OBJS=startocaml.$(O) ocamlres.$(O) ocaml.$(O) menu.$(O)
+OBJS=startocaml.$(O) ocamlres.$(O) ocaml.$(O) menu.$(O) \
+  history.$(O) editbuffer.$(O)
 
 LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,advapi32) $(call SYSLIB,gdi32) \
      $(call SYSLIB,user32) $(call SYSLIB,comdlg32) $(call SYSLIB,comctl32)
@@ -38,7 +39,7 @@ ifeq ($(TOOLCHAIN),mingw)
 	windres -i ocaml.rc -o $@
 endif
 
-$(OBJS): inria.h inriares.h
+$(OBJS): inria.h inriares.h history.h editbuffer.h
 
 clean:
 	rm -f ocamlwin.exe *.$(O) *.pdb ocamlwin.ilk
diff --git a/win32caml/editbuffer.c b/win32caml/editbuffer.c
new file mode 100644
index 00000000..480d22d8
--- /dev/null
+++ b/win32caml/editbuffer.c
@@ -0,0 +1,514 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*  Developed by Jacob Navia.                                          */
+/*  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.     */
+/*                                                                     */
+/***********************************************************************/
+
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+#include <string.h>
+#include <stdlib.h>
+#include "inriares.h"
+#include "inria.h"
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_addline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Adds a line to the current edit buffer
+ Input:			Line of text to append to the end
+ Output:
+ Errors:
+--------------------------------------------------------------------------
+ Edit History:
+	18 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Corrected doubly linked list issue
+------------------------------------------------------------------------*/
+BOOL editbuffer_addline(EditBuffer* edBuf, char* line)
+{
+	LineList *tail = NULL; //head of the edit buffer line list
+	LineList *newline = NULL;
+
+	// sanity check
+	if(edBuf == NULL)
+	{
+		return FALSE;
+	}
+
+	// perform edit buffer sanity checks
+	if((edBuf->LineCount < 0) || (edBuf->Lines == NULL))
+	{
+		edBuf->LineCount = 0;
+	}
+
+	// move to the end of the line list in the edit buffer
+	if((tail = edBuf->Lines) != NULL)
+		for( ; tail->Next != NULL; tail = tail->Next);
+
+	// create the new line entry
+	newline = (LineList*)SafeMalloc(sizeof(LineList));
+	newline->Next = NULL;
+	newline->Prev = tail;
+	newline->Text = (char*)SafeMalloc(strlen(line)+1);
+	strncpy(newline->Text, line, strlen(line)+1);
+	newline->Text[strlen(line)] = '\0';
+
+	// add it to the list as the head or the tail
+	if(tail != NULL)
+	{
+		tail->Next = newline;
+	} else {
+		edBuf->Lines = newline;
+	}
+
+	// update the number of lines in the buffer
+	edBuf->LineCount++;
+
+	return TRUE;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_updateline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Updates the edit buffer's internal contents for a line
+ Input:			idx - Line index
+				line - String to add
+ Output:		if the line was updated or not
+ Errors:
+------------------------------------------------------------------------*/
+BOOL editbuffer_updateline(EditBuffer* edBuf, int idx, char* line)
+{
+	LineList *update = edBuf->Lines; //head of the edit buffer line list
+	LineList *newline = NULL;
+	int i;
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return FALSE;
+	} else if(	(edBuf->LineCount == 0) ||
+				(edBuf->Lines == NULL) ||
+				(idx >= edBuf->LineCount) ||
+				(idx < 0) ) {
+		return FALSE;
+	}
+
+	// move to the index in the line list
+	// i left in update != NULL as a sanity check
+	for(i = 0; ((update != NULL) && (i != idx)); update = update->Next, i++);
+
+	// did things mess up?
+	if( (update == NULL) || (i != idx) )
+	{
+		return FALSE;
+	}
+
+	// get rid of the old line
+	free(update->Text);
+
+	// get the new line updated
+	update->Text = (char*)SafeMalloc(strlen(line)+1);
+	strncpy(update->Text, line, strlen(line)+1);
+	update->Text[strlen(line)] = '\0';
+
+	return TRUE;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_updateoraddline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Updates the edit buffer's internal contents for a line
+ Input:			idx - Line index
+				line - String to add
+ Output:		if the line was updated or not
+ Errors:
+------------------------------------------------------------------------*/
+BOOL editbuffer_updateoraddline(EditBuffer* edBuf, int idx, char* line)
+{
+	LineList *update;
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return FALSE;
+	} else if((idx > edBuf->LineCount) || (idx < 0)) {
+		return FALSE;
+	}
+
+	update = edBuf->Lines; //head of the edit buffer line list
+
+	// do we update or add?
+	if((idx < edBuf->LineCount) && (edBuf->Lines != NULL))
+	{	//interior line, update
+		return editbuffer_updateline(edBuf, idx, line);
+	} else {
+		//fence line, add
+		return editbuffer_addline(edBuf, line);
+	}
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_removeline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Removes a line from the edit buffer
+ Input:			idx - Line index to remove
+ Output:		if the line was removed or not
+ Errors:
+--------------------------------------------------------------------------
+ Edit History:
+	18 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added to allow backspace and delete support
+		- Corrected doubly linked list issue
+------------------------------------------------------------------------*/
+BOOL editbuffer_removeline(EditBuffer* edBuf, int idx)
+{
+	LineList *update = NULL;
+	int i = 0;
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return FALSE;
+	} else if(	(edBuf->LineCount == 0) ||
+				(edBuf->Lines == NULL) ||
+				(idx >= edBuf->LineCount) ||
+				(idx < 0) ) {
+		return FALSE;
+	}
+	
+	// move to the index in the line list
+	// i left in update != NULL as a sanity check
+	for(i = 0, update = edBuf->Lines; ((update != NULL) && (i != idx)); update = update->Next, i++);
+
+	// remove this line
+	if(update != NULL)
+	{
+		// break links, removing our line
+		if(update->Prev != NULL)
+		{
+			// we're not the first so just break the link
+			update->Prev->Next = update->Next;
+			
+			// fix the prev check
+			if(update->Next != NULL)
+				update->Next->Prev = update->Prev;
+		} else {
+			// we're the first, attach the next guy to lines
+			edBuf->Lines = update->Next;
+		}
+
+		// one less line to worry about
+		edBuf->LineCount--;
+
+		// get rid of the text
+		if(update->Text != NULL)
+			free(update->Text);
+
+		// get rid of us
+		free(update);
+
+		return TRUE;
+	}
+
+	return FALSE;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_getasline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Returns the edit buffer as one big line, \n's and \t's
+				become spaces.
+ Input:
+ Output:
+ Errors:
+------------------------------------------------------------------------*/
+char* editbuffer_getasline(EditBuffer* edBuf)
+{
+	LineList *line = NULL; //head of the edit buffer line list
+	char* retline = (char*)realloc(NULL, 1);
+	unsigned int i = 0;
+
+	// fix retline bug
+	retline[0] = '\0';
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return NULL;
+	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
+		// fix any possible errors that may come from this
+		edBuf->LineCount = 0;
+		edBuf->Lines = NULL;
+		return NULL;
+	}
+
+	// get the big line
+	for(line = edBuf->Lines; line != NULL; line = line->Next)
+	{
+		if(line->Text != NULL)
+		{
+			retline = (char*)realloc(retline, (strlen(retline) + strlen(line->Text) + (strlen(retline) > 0 ? 2 : 1)));
+
+			if(strlen(retline) > 0)
+				retline = strcat(retline, " ");
+
+			retline = strcat(retline, line->Text);
+
+			//concat in the hoouuusssseee!
+		}
+	}
+
+	// now we have the big line, so lets ditch all \n's \t's and \r's
+	for(i = 0; i < strlen(retline); i++)
+	{
+		switch(retline[i])
+		{
+			case '\n':
+			case '\t':
+			case '\r':
+				retline[i] = ' ';
+		}
+	}
+
+	return retline;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_getasbuffer ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Returns the edit buffer as one big line, \n's and \t's
+				become spaces.
+ Input:
+ Output:
+ Errors:
+------------------------------------------------------------------------*/
+char* editbuffer_getasbuffer(EditBuffer* edBuf)
+{
+	LineList *line = NULL; //head of the edit buffer line list
+	char* retbuf = (char*)realloc(NULL, 1);
+	unsigned int i = 0;
+
+	// fix retline bug
+	retbuf[0] = '\0';
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return NULL;
+	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
+		// fix any possible errors that may come from this
+		edBuf->LineCount = 0;
+		edBuf->Lines = NULL;
+		return NULL;
+	}
+
+	// get the big line
+	for(line = edBuf->Lines; line != NULL; line = line->Next)
+	{
+		if(line->Text != NULL)
+		{
+			int len = strlen(retbuf);
+			len += strlen(line->Text) + (len > 0 ? 3 : 1);
+
+			retbuf = (char*)realloc(retbuf, len);
+
+			if(strlen(retbuf) > 0)
+				retbuf = strcat(retbuf, "\r\n");
+
+			retbuf = strcat(retbuf, line->Text);
+
+			retbuf[len-1] = '\0';
+
+			//concat in the hoouuusssseee!
+		}
+	}
+
+	return retbuf;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_lastline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Returns the last line in the edit buffer
+ Input:
+ Output:
+ Errors:
+------------------------------------------------------------------------*/
+char* editbuffer_lastline(EditBuffer* edBuf)
+{
+	LineList *line = NULL; //head of the edit buffer line list
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return NULL;
+	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
+		// fix any possible errors that may come from this
+		edBuf->LineCount = 0;
+		edBuf->Lines = NULL;
+		return NULL;
+	}
+
+	// go to the last line
+	for(line = edBuf->Lines; line->Next != NULL; line = line->Next);
+
+	return line->Text;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_copy ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Makes an exact copy of an edit buffer
+ Input:
+ Output:
+ Errors:
+--------------------------------------------------------------------------
+ Edit History:
+	16 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added to make copies of history entries
+	18 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Corrected doubly linked list issue
+	06 Oct  2003 - Chris Watford watford@uiuc.edu
+		- Added isCorrect flag
+------------------------------------------------------------------------*/
+EditBuffer* editbuffer_copy(EditBuffer* edBuf)
+{
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return NULL;
+	} else {
+		EditBuffer* copy = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
+		LineList* lines = edBuf->Lines;
+		LineList* lastLine = NULL;
+
+		// clear its initial values
+		copy->LineCount = 0;
+		copy->Lines = NULL;
+		copy->isCorrect = FALSE;
+
+		// well we don't have to copy much
+		if((lines == NULL) || (edBuf->LineCount <= 0))
+		{
+			return copy;
+		}
+
+		// get if its correct
+		copy->isCorrect = edBuf->isCorrect;
+
+		// go through each line, malloc it and add it
+		for( ; lines != NULL; lines = lines->Next)
+		{
+			LineList* curline = (LineList*)SafeMalloc(sizeof(LineList));
+			curline->Next = NULL;
+			curline->Prev = NULL;
+
+			// if there was a last line, link them to us
+			if(lastLine != NULL)
+			{
+				lastLine->Next = curline;
+				curline->Prev = lastLine;
+			}
+
+			// are we the first line? add us to the edit buffer as the first
+			if(copy->Lines == NULL)
+			{
+				copy->Lines = curline;
+			}
+
+			// check if there is text on the line
+			if(lines->Text == NULL)
+			{	// no text, make it blankz0r
+				curline->Text = (char*)SafeMalloc(sizeof(char));
+				curline->Text[0] = '\0';
+			} else {
+				// there is text, copy it and null-terminate
+				curline->Text = (char*)SafeMalloc(strlen(lines->Text) + 1);
+				strncpy(curline->Text, lines->Text, strlen(lines->Text));
+				curline->Text[strlen(lines->Text)] = '\0';
+			}
+
+			// up the line count and make us the last line
+			copy->LineCount++;
+			lastLine = curline;
+		}
+
+		// return our new copy
+		return copy;
+	}
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_destroy ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Destroys an edit buffer
+ Input:
+ Output:
+ Errors:
+------------------------------------------------------------------------*/
+void editbuffer_destroy(EditBuffer* edBuf)
+{
+	// sanity checks
+	if(edBuf == NULL)
+	{	// nothing to do
+		return;
+	} else if(edBuf->Lines != NULL) {
+		LineList* lastline = NULL;
+
+		// loop through each line free'ing its text
+		for( ; edBuf->Lines != NULL; edBuf->Lines = edBuf->Lines->Next)
+		{
+			if(edBuf->Lines->Text != NULL)
+				free(edBuf->Lines->Text);
+
+			// if there was a line before us, free it
+			if(lastline != NULL)
+			{
+				free(lastline);
+				lastline = NULL;
+			}
+
+			lastline = edBuf->Lines;
+		}
+
+		// free the last line
+		free(lastline);
+	}
+
+	// free ourself
+	free(edBuf);
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_new ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Creates an edit buffer
+ Input:
+ Output:
+ Errors:
+--------------------------------------------------------------------------
+ Edit History:
+	06 Oct  2003 - Chris Watford watford@uiuc.edu
+		- Added isCorrect flag
+------------------------------------------------------------------------*/
+EditBuffer* editbuffer_new(void)
+{
+	// create a new one
+	EditBuffer *edBuf = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
+	
+	// default vals
+	edBuf->LineCount = 0;
+	edBuf->Lines = NULL;
+	edBuf->isCorrect = FALSE;
+	
+	// return it
+	return edBuf;
+}
diff --git a/win32caml/editbuffer.h b/win32caml/editbuffer.h
new file mode 100644
index 00000000..ce8dccfd
--- /dev/null
+++ b/win32caml/editbuffer.h
@@ -0,0 +1,47 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Jacob Navia, after Xavier Leroy                          */
+/*                                                                     */
+/*  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.     */
+/*                                                                     */
+/***********************************************************************/
+
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+#ifndef _EDITBUFFER_H_
+#define _EDITBUFFER_H_
+
+// All the below was added by Chris Watford watford@uiuc.edu
+
+typedef struct tagLineList {
+        struct tagLineList	*Next;
+		struct tagLineList	*Prev;
+        char				*Text;
+} LineList;
+
+typedef struct tagEditBuffer {
+	int					LineCount;
+	struct tagLineList	*Lines;
+	BOOL				isCorrect;
+} EditBuffer;
+
+BOOL		editbuffer_addline			(EditBuffer* edBuf, char* line);
+BOOL		editbuffer_updateline		(EditBuffer* edBuf, int idx, char* line);
+BOOL		editbuffer_updateoraddline	(EditBuffer* edBuf, int idx, char* line);
+BOOL		editbuffer_removeline		(EditBuffer* edBuf, int idx);
+char*		editbuffer_getasline		(EditBuffer* edBuf);
+char*		editbuffer_getasbuffer		(EditBuffer* edBuf);
+char*		editbuffer_lastline			(EditBuffer* edBuf);
+EditBuffer*	editbuffer_copy				(EditBuffer* edBuf);
+void		editbuffer_destroy			(EditBuffer* edBuf);
+EditBuffer*	editbuffer_new				(void);
+
+#endif
diff --git a/win32caml/history.c b/win32caml/history.c
new file mode 100644
index 00000000..11397ac6
--- /dev/null
+++ b/win32caml/history.c
@@ -0,0 +1,98 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Jacob Navia, after Xavier Leroy                          */
+/*                                                                     */
+/*  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.     */
+/*                                                                     */
+/***********************************************************************/
+
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+#include "inria.h"
+#include "history.h"
+
+/*------------------------------------------------------------------------
+Procedure:     AddToHistory ID:2
+Author:		   Chris Watford watford@uiuc.edu
+Purpose:       Adds an edit buffer to the history control
+Input:		   Pointer to the edit buffer to add
+Output:
+Errors:
+--------------------------------------------------------------------------
+Edit History:
+	15 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Complete rewrite
+		- Got it to add the edit buffer to the history
+	17 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added doubly link list support
+------------------------------------------------------------------------*/
+void AddToHistory(EditBuffer *edBuf)
+{
+	StatementHistory *newLine;
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return;
+	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
+		// fix any possible errors that may come from this
+		edBuf->LineCount = 0;
+		edBuf->Lines = NULL;
+		return;
+	}
+
+	// setup newline and add as the front of the linked list
+	newLine = SafeMalloc(sizeof(StatementHistory));
+	newLine->Next = History;
+	newLine->Prev = NULL;
+	newLine->Statement = edBuf;
+
+	// setup back linking
+	if(History != NULL)
+		History->Prev = newLine;
+
+	// set the history up
+	History = newLine;
+
+	// search for the new history tail
+	for(HistoryTail = (HistoryTail != NULL ? HistoryTail : History); HistoryTail->Next != NULL; HistoryTail = HistoryTail->Next);
+}
+
+/*------------------------------------------------------------------------
+Procedure:     GetHistoryLine ID:2
+Author:		   Chris Watford watford@uiuc.edu
+Purpose:       Returns an entry from the history table
+Input:		   Index of the history entry to return
+Output:		   The history entry as a single line
+Errors:
+--------------------------------------------------------------------------
+Edit History:
+	15 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Complete rewrite
+	17 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added doubly link list support
+------------------------------------------------------------------------*/
+char *GetHistoryLine(int n)
+{
+	StatementHistory *histentry = History;
+	int i;
+
+	// traverse linked list looking for member n
+	for (i = 0; ((i < n) && (histentry != NULL)); i++, histentry = histentry->Next);
+
+	// figure out what to return
+	if (histentry != NULL)
+	{
+		return editbuffer_getasline(histentry->Statement);
+	} else {
+		return "";
+	}
+}
diff --git a/win32caml/history.h b/win32caml/history.h
new file mode 100644
index 00000000..a9ba8584
--- /dev/null
+++ b/win32caml/history.h
@@ -0,0 +1,35 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Jacob Navia, after Xavier Leroy                          */
+/*                                                                     */
+/*  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.     */
+/*                                                                     */
+/***********************************************************************/
+
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+#ifndef _HISTORY_H_
+#define _HISTORY_H_
+
+#include "editbuffer.h"
+
+// Simple linked list for holding the history lines
+typedef struct tagStatementHistory {
+        struct tagStatementHistory	*Next;
+		struct tagStatementHistory	*Prev;
+        EditBuffer					*Statement;
+} StatementHistory;
+
+void	AddToHistory	(EditBuffer *edBuf);
+char	*GetHistoryLine	(int n);
+static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam);
+
+#endif
diff --git a/win32caml/inria.h b/win32caml/inria.h
index 4de3f38d..22223aa2 100644
--- a/win32caml/inria.h
+++ b/win32caml/inria.h
@@ -10,7 +10,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: inria.h,v 1.4 2002/07/23 14:12:02 doligez Exp $ */
+/* $Id: inria.h,v 1.5 2004/06/17 07:33:44 xleroy Exp $ */
 
 /*------------------------------------------------------------------------
  Module:        D:\lcc\inria\inria.h
@@ -56,8 +56,12 @@
                 something in the pipe. This is enough for most
                 applications.
 ------------------------------------------------------------------------*/
+#ifndef _INRIA_H_
+#define _INRIA_H_
 
 #include <windows.h>
+#include "editbuffer.h"
+#include "history.h"
 
 // In this structure should go eventually all global variables scattered
 // through the program.
@@ -90,26 +94,33 @@ void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam);
 int GetOcamlPath(void);                         // Finds where ocaml.exe is
 void ForceRepaint(void);                        // Ditto.
 void AddLineToControl(char *buf);
+void AddStringToControl(char* buf);
 char *GetHistoryLine(int n);            // Gets the nth history line base 1.
 int StartOcaml(void);
+void InterruptOcaml(void);
+int ResetText(void);
+BOOL SendingFullCommand(void);
+void RewriteCurrentEditBuffer(void);
+void RefreshCurrentEditBuffer(void);
+
 // **************** User defined window messages *************
-#define WM_NEWLINE      (WM_USER+6000)
-#define WM_TIMERTICK (WM_USER+6001)
-#define WM_QUITOCAML (WM_USER+6002)
+#define WM_NEWLINE		(WM_USER+6000)
+#define WM_TIMERTICK	(WM_USER+6001)
+#define WM_QUITOCAML	(WM_USER+6002)
+#define WM_SYNTAXERROR	(WM_USER+6003)
+#define WM_UNBOUNDVAL	(WM_USER+6004)
+#define WM_ILLEGALCHAR	(WM_USER+6005)
+
 // ********************** Structures ***********************
 typedef struct tagPosition {
         int line;
         int col;
 } POSITION;
 
-// Simple linked list for holding the history lines
-typedef struct tagHistory {
-        struct tagHistory *Next;
-        char *Text;
-} HISTORYLINE;
-
 extern void *SafeMalloc(int);
-extern HISTORYLINE *History; // The root of the history lines
+extern StatementHistory *History; // The root of the history lines
+extern StatementHistory *HistoryTail; // The tail of the history lines
+extern EditBuffer *CurrentEditBuffer; // current edit buffer
 
 #define IDEDITCONTROL 15432
-
+#endif
diff --git a/win32caml/menu.c b/win32caml/menu.c
index fd23f581..e945e627 100644
--- a/win32caml/menu.c
+++ b/win32caml/menu.c
@@ -10,19 +10,25 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: menu.c,v 1.6 2003/09/09 09:07:14 xleroy Exp $ */
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+/* $Id: menu.c,v 1.7 2004/06/17 07:33:44 xleroy Exp $ */
 
 #include <stdio.h>
 #include <windows.h>
 #include <Richedit.h>
 #include "inria.h"
 #include "inriares.h"
+#include "history.h"
 
-void InterruptOcaml(void);
 LOGFONT CurrentFont;
 int CurrentFontFamily = (FIXED_PITCH | FF_MODERN);
 int CurrentFontStyle;
 char CurrentFontName[64] = "Courier";
+
 /*------------------------------------------------------------------------
  Procedure:     OpenMlFile ID:1
  Purpose:       Opens a file, either a source file (*.ml) or an *.cmo
@@ -68,6 +74,7 @@ int OpenMlFile(char *fname,int lenbuf)
         }
         return r;
 }
+
 /*------------------------------------------------------------------------
  Procedure:     GetSaveName ID:1
  Purpose:       Get a name to save the current session (Save as menu
@@ -111,6 +118,51 @@ int GetSaveName(char *fname,int lenbuf)
                 return 0;
         else return 1;
 }
+
+/*------------------------------------------------------------------------
+ Procedure:     GetSaveMLName ID:1
+ Purpose:       Get a name to save the current OCaml code to (Save as menu
+                item)
+ Input:         A buffer where the name of the file will be stored,
+                and its length
+ Output:        The name of the file choosen by the user will be
+                stored in the buffer
+ Errors:        none
+------------------------------------------------------------------------*/
+int GetSaveMLName(char *fname, int lenbuf)
+{
+        OPENFILENAME ofn;
+        int r;
+        char *p,defext[5],tmp[512];
+
+        memset(&ofn,0,sizeof(OPENFILENAME));
+        memset(tmp,0,sizeof(tmp));
+        fname[0] = 0;
+        strcpy(tmp,"OCaml Source Files|*.ml");
+        p = tmp;
+        while (*p) {
+                if (*p == '|')
+                        *p = 0;
+                p++;
+        }
+        strcpy(defext,"ml");
+        ofn.lStructSize = sizeof(OPENFILENAME);
+        ofn.hwndOwner = hwndMain;
+        ofn.lpstrFilter = tmp;
+        ofn.nFilterIndex = 1;
+        ofn.hInstance = hInst;
+        ofn.lpstrFile = fname;
+        ofn.lpstrTitle = "Save as";
+        ofn.lpstrInitialDir = LibDir;
+        ofn.nMaxFile = lenbuf;
+        ofn.Flags =  OFN_NOCHANGEDIR | OFN_LONGNAMES |
+                OFN_HIDEREADONLY |OFN_EXPLORER;
+        r = GetSaveFileName(&ofn);
+        if (r == 0)
+                return 0;
+        else return 1;
+}
+
 /*------------------------------------------------------------------------
  Procedure:     BrowseForFile ID:1
  Purpose:       Let's the user browse for a certain kind of file.
@@ -304,6 +356,13 @@ void ForceRepaint(void)
         InvalidateRect(hwndEdit,NULL,1);
 }
 
+/*------------------------------------------------------------------------
+ Procedure:     Add_Char_To_Queue ID:1
+ Purpose:       Puts a character onto the buffer
+ Input:         The char to be added
+ Output:        None
+ Errors:
+------------------------------------------------------------------------*/
 static void Add_Char_To_Queue(int c)
 {
         HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
@@ -326,12 +385,46 @@ void AddLineToControl(char *buf)
 
         if (*buf == 0)
                 return;
+
         hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER);
+
         GotoEOF();
+
         SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)buf);
         SendMessage(hEditCtrl,WM_CHAR,'\r',0);
 }
 
+/*------------------------------------------------------------------------
+ Procedure:     AddStringToControl ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       It will ad the given text at the end of the edit
+                control. This simulates user input. The history will not
+				be modified by this procedure.
+ Input:         The text to be added
+ Output:        None
+ Errors:        If the line is empty, nothing will be done
+--------------------------------------------------------------------------
+Edit History:
+	16 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Basically this is AddLineToControl, but without appending a
+		  newline
+------------------------------------------------------------------------*/
+void AddStringToControl(char* buf)
+{
+        HWND hEditCtrl;
+
+		if(buf == NULL)
+			return;
+
+        if((*buf) == 0)
+            return;
+
+        hEditCtrl = (HWND)GetWindowLong(hwndSession, DWL_USER);
+        GotoEOF();
+
+        SendMessage(hEditCtrl ,EM_REPLACESEL, (WPARAM)FALSE, (LPARAM)buf);
+}
+
 /*------------------------------------------------------------------------
  Procedure:     AboutDlgProc ID:1
  Purpose:       Shows the "About" dialog box
@@ -345,6 +438,7 @@ static BOOL CALLBACK AboutDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM
                 EndDialog(hDlg,1);
         return 0;
 }
+
 /*------------------------------------------------------------------------
  Procedure:     HistoryDlgProc ID:1
  Purpose:       Shows the history of the session. Only input lines
@@ -355,24 +449,33 @@ static BOOL CALLBACK AboutDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM
  Input:         Normal windows callback
  Output:
  Errors:
+--------------------------------------------------------------------------
+Edit History:
+	15 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added support for my StatementHistory structure
+		- Added the ability to export it as its exact entry, rather than
+		  just a 1 liner
 ------------------------------------------------------------------------*/
 static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam)
 {
-        HISTORYLINE *rvp;
+        StatementHistory *histentry;
         int idx;
         RECT rc;
 
         switch (message) {
                 case WM_INITDIALOG:
                         SendDlgItemMessage(hDlg,IDLIST,WM_SETFONT,(WPARAM)ProgramParams.hFont,0);
-                        rvp = History;
+                        histentry = History; // get our statement history object
                         idx = 0;
-                        while (rvp) {
-                                SendDlgItemMessage(hDlg,IDLIST,LB_INSERTSTRING,0,(LPARAM)rvp->Text);
+
+						// loop through each history entry adding it to the dialog
+                        while (histentry != NULL) {
+                                SendDlgItemMessage(hDlg,IDLIST,LB_INSERTSTRING,0,(LPARAM)editbuffer_getasline(histentry->Statement));
                                 SendDlgItemMessage(hDlg,IDLIST,LB_SETITEMDATA,0,(LPARAM)idx);
-                                rvp = rvp->Next;
+                                histentry = histentry->Next;
                                 idx++;
                         }
+
                         SendDlgItemMessage(hDlg,IDLIST,LB_SETCURSEL,(LPARAM)idx-1,0);
                         return 1;
                 case WM_COMMAND:
@@ -401,6 +504,7 @@ static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPAR
         }
         return 0;
 }
+
 /*------------------------------------------------------------------------
  Procedure:     SaveText ID:1
  Purpose:       Saves the contents of the session transcript. It will
@@ -409,6 +513,10 @@ static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPAR
  Output:        The session is saved
  Errors:        If it can't open the file for writing it will show an
                 error box
+--------------------------------------------------------------------------
+ Edit History:
+	06 Oct  2003 - Chris Watford watford@uiuc.edu
+		- Corrected wsprintf error
 ------------------------------------------------------------------------*/
 static void SaveText(char *fname)
 {
@@ -419,54 +527,155 @@ static void SaveText(char *fname)
         char *buf = SafeMalloc(8192);
 
         f = fopen(fname,"wb");
-        if (f == NULL) {
-                wsprintf("Impossible to open %s for writing",fname);
-                ShowDbgMsg(buf);
-                return;
+        if (f == NULL)
+		{
+			// corrected error using wsprintf
+            wsprintf(buf, "Impossible to open %s for writing", fname);
+
+            ShowDbgMsg(buf);
+            return;
         }
-        for (i=0; i<linesCount;i++) {
+
+        for (i = 0; i < linesCount; i++)
+		{
                 *(unsigned short *)buf = 8100;
-                len = SendMessage(hEdit,EM_GETLINE,i,(LPARAM)buf);
-                buf[len] = 0;
-                strcat(buf,"\r\n");
-                fwrite(buf,1,len+2,f);
+                len = SendMessage(hEdit, EM_GETLINE, i, (LPARAM)buf);
+                buf[len] = '\0';
+				fprintf(f, "%s\r\n", buf+1);
+                //fwrite(buf,1,len+2,f);
         }
+
         fclose(f);
         free(buf);
 }
 
-
-static void Add_Clipboard_To_Queue(void)
+/*------------------------------------------------------------------------
+ Procedure:     SaveML ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Saves the ML source to a file, commenting out functions
+				that contained errors
+ Input:         The name of the file where the session will be saved
+ Output:        The session is saved
+ Errors:        If it can't open the file for writing it will show an
+                error box
+------------------------------------------------------------------------*/
+static void SaveML(char *fname)
 {
-    if (IsClipboardFormatAvailable(CF_TEXT) &&
-        OpenClipboard(hwndMain))
-    {
-        HANDLE hClipData = GetClipboardData(CF_TEXT);
-
-        if (hClipData)
-        {
-            char *str = GlobalLock(hClipData);
-
-            if (str)
-                while (*str)
-                {
-                    if (*str != '\r')
-                        Add_Char_To_Queue(*str);
-                    str++;
-                }
-            GlobalUnlock(hClipData);
+        FILE *f;
+        char *buf = SafeMalloc(8192);
+
+        f = fopen(fname, "wb");
+
+        if(f == NULL)
+		{
+                wsprintf(buf, "Impossible to open %s for writing", fname);
+                ShowDbgMsg(buf);
+                return;
         }
-        CloseClipboard();
-    }
 
+		fprintf(f, "(* %s *)\r\n\r\n", fname);
+
+		if(History != NULL)
+		{
+			StatementHistory *h = NULL;
+			EditBuffer *stmt = NULL;
+
+			// get to the end
+			for(h = History; h->Next != NULL; h = h->Next);
+
+			// go back :(
+			// this is NOT the fastest method, BUT this is the easiest
+			// on the subsystem
+			for(; h != NULL; h = h->Prev)
+			{
+				stmt = h->Statement;
+
+				if(stmt != NULL)
+				{
+					// comment out incorrect lines
+					if(stmt->isCorrect)
+					{
+						char *buff = editbuffer_getasbuffer(stmt);
+						fprintf(f, "%s\r\n", buff);
+						free(buff);
+					} else {
+						char *buff = editbuffer_getasbuffer(stmt);
+						fprintf(f, "(* Syntax Error or Unbound Value\r\n%s\r\n *)\r\n", buff);
+						free(buff);
+					}
+				}
+
+				fprintf(f, "\r\n");
+			}
+		}
+
+        fclose(f);
+        free(buf);
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     Add_Clipboard_To_Queue ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Adds the clipboard text to the control
+ Input:
+ Output:
+ Errors:
+--------------------------------------------------------------------------
+ Edit History:
+	16 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added method to update edit buffer with paste contents
+------------------------------------------------------------------------*/
+static void Add_Clipboard_To_Queue(void)
+{
+    if (IsClipboardFormatAvailable(CF_TEXT) && OpenClipboard(hwndMain))
+    {
+        HANDLE hClipData = GetClipboardData(CF_TEXT);
+
+        if (hClipData != NULL)
+        {
+            char *str = GlobalLock(hClipData);
+
+            if (str != NULL)
+			{
+                while ((*str) != 0)
+                {
+                    if (*str != '\r')
+                        Add_Char_To_Queue(*str);
+
+                    str++;
+                }
+
+				// added to fix odd errors
+				RefreshCurrentEditBuffer();
+			}
+
+            GlobalUnlock(hClipData);
+        }
+
+        CloseClipboard();
+    }
 }
 
+/*------------------------------------------------------------------------
+ Procedure:     CopyToClipboard ID:1
+ Purpose:       Copies text to the clipboard
+ Input:			Window with the edit control
+ Output:
+ Errors:
+------------------------------------------------------------------------*/
 static void CopyToClipboard(HWND hwnd)
 {
         HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
         SendMessage(hwndEdit,WM_COPY,0,0);
 }
 
+/*------------------------------------------------------------------------
+ Procedure:     ResetText ID:1
+ Purpose:       Resets the text? I'm not really sure
+ Input:
+ Output:		Always returns 0
+ Errors:
+------------------------------------------------------------------------*/
 int ResetText(void)
 {
         HWND hwndEdit = (HWND) GetWindowLong(hwndSession,DWL_USER);
@@ -495,6 +704,12 @@ int ResetText(void)
  Input:
  Output:
  Errors:
+--------------------------------------------------------------------------
+ Edit History:
+	06 Oct  2003 - Chris Watford watford@uiuc.edu
+		- Removed entries that crashed OCaml
+		- Removed useless entries
+		- Added Save ML and Save Transcript
 ------------------------------------------------------------------------*/
 void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam)
 {
@@ -508,11 +723,11 @@ void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam)
                                 char *buf = SafeMalloc(512);
                                 char *p = strrchr(fname,'.');
                                 if (p && !stricmp(p,".ml")) {
-                                        wsprintf(buf,"#use \"%s\";;",fname);
+                                        wsprintf(buf, "#use \"%s\";;", fname);
                                         AddLineToControl(buf);
                                 }
                                 else if (p && !stricmp(p,".cmo")) {
-                                        wsprintf(buf,"#load \"%s\";;",fname);
+                                        wsprintf(buf, "#load \"%s\";;", fname);
                                         AddLineToControl(buf);
                                 }
                                 free(buf);
@@ -531,22 +746,42 @@ void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam)
                 case IDM_EDITCOPY:
                         CopyToClipboard(hwnd);
                         break;
-                case IDM_SAVE:
+
+				// updated to save a transcript
+                case IDM_SAVEAS:
                         fname = SafeMalloc(512);
                         if (GetSaveName(fname,512)) {
                                 SaveText(fname);
                         }
                         free(fname);
                         break;
+
+				// updated to save an ML file
+				case IDM_SAVE:
+                        fname = SafeMalloc(512);
+                        if (GetSaveMLName(fname,512))
+						{
+                                SaveML(fname);
+                        }
+                        free(fname);
+                        break;
+
+				// updated to work with new history system
                 case IDM_HISTORY:
                         r = CallDlgProc(HistoryDlgProc,IDD_HISTORY);
-                        if (r) {
+
+                        if (r)
+						{
                                 AddLineToControl(GetHistoryLine(r-1));
                         }
                         break;
+
                 case IDM_PRINTSU:
-                        CallPrintSetup();
+						// Removed by Chris Watford
+						// seems to die
+                        // CallPrintSetup();
                         break;
+
                 case IDM_FONT:
                         CallChangeFont(hwndMain);
                         break;
@@ -563,6 +798,8 @@ void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam)
                 case IDM_EDITUNDO:
                         Undo(hwnd);
                         break;
+
+				/* Removed, really not very useful in this IDE
                 case IDM_WINDOWTILE:
                         SendMessage(hwndMDIClient,WM_MDITILE,0,0);
                         break;
@@ -572,6 +809,8 @@ void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam)
                 case IDM_WINDOWICONS:
                         SendMessage(hwndMDIClient,WM_MDIICONARRANGE,0,0);
                         break;
+				*/
+
                 case IDM_EXIT:
                         PostMessage(hwnd,WM_CLOSE,0,0);
                         break;
@@ -589,4 +828,3 @@ void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam)
                         break;
         }
 }
-
diff --git a/win32caml/ocaml.c b/win32caml/ocaml.c
index e5d8ada5..38b8dc9c 100644
--- a/win32caml/ocaml.c
+++ b/win32caml/ocaml.c
@@ -1,4 +1,3 @@
-/***********************************************************************/
 /*                                                                     */
 /*                           Objective Caml                            */
 /*                                                                     */
@@ -10,14 +9,20 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: ocaml.c,v 1.6 2003/09/09 09:07:14 xleroy Exp $ */
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+/* $Id: ocaml.c,v 1.7 2004/06/17 07:33:44 xleroy Exp $ */
 
 /*@@ Wedit generated application. Written Sat Jun 02 18:22:38 2001
- @@header: D:\lcc\inria\inriares.h
- @@resources: D:\lcc\inria\inria.rc
- Do not edit outside the indicated areas */
-/*<---------------------------------------------------------------------->*/
+@@header: D:\lcc\inria\inriares.h
+@@resources: D:\lcc\inria\inria.rc
+Do not edit outside the indicated areas */
 /*<---------------------------------------------------------------------->*/
+
+#include <stdio.h>
 #include <windows.h>
 #include <windowsx.h>
 #include <commctrl.h>
@@ -26,10 +31,13 @@
 #include <Richedit.h>
 #include "inriares.h"
 #include "inria.h"
+
+#define VK_BACKSPACE    0x108
+
+/*<---------------------------------------------------------------------->*/
 int EditControls = IDEDITCONTROL;
 static WNDPROC lpEProc;
 static char lineBuffer[1024*32];
-int ResetText(void);
 int ReadToLineBuffer(void);
 int AddLineBuffer(void);
 static int busy;
@@ -40,7 +48,11 @@ char OcamlPath[512];
 HBRUSH BackgroundBrush;
 COLORREF BackColor = RGB(255,255,255);
 PROGRAM_PARAMS ProgramParams;
-HISTORYLINE *History;
+StatementHistory *History = NULL;
+StatementHistory *HistoryTail = NULL;
+StatementHistory *historyEntry = NULL;
+EditBuffer *CurrentEditBuffer = NULL; // current edit buffer
+
 /*<----------------- global variables --------------------------------------->*/
 HANDLE hInst;           // Instance handle
 HWND hwndMain;          //Main window handle
@@ -52,765 +64,1472 @@ PROCESS_INFORMATION pi;
 HWND  hWndStatusbar;
 
 /*------------------------------------------------------------------------
- Procedure:     UpdateStatusBar ID:1
- Purpose:       Updates the statusbar control with the appropiate
-                text
- Input:         lpszStatusString: Charactar string that will be shown
-                partNumber: index of the status bar part number.
-                displayFlags: Decoration flags
- Output:        none
- Errors:        none
+Procedure:     UpdateStatusBar ID:1
+Purpose:       Updates the statusbar control with the appropiate
+text
+Input:         lpszStatusString: Charactar string that will be shown
+partNumber: index of the status bar part number.
+displayFlags: Decoration flags
+Output:        none
+Errors:        none
 
 ------------------------------------------------------------------------*/
 void UpdateStatusBar(LPSTR lpszStatusString, WORD partNumber, WORD displayFlags)
 {
-    SendMessage(hWndStatusbar,
-                SB_SETTEXT,
-                partNumber | displayFlags,
-                (LPARAM)lpszStatusString);
+	SendMessage(hWndStatusbar,
+		SB_SETTEXT,
+		partNumber | displayFlags,
+		(LPARAM)lpszStatusString);
 }
 
 
 /*------------------------------------------------------------------------
- Procedure:     MsgMenuSelect ID:1
- Purpose:       Shows in the status bar a descriptive explaation of
-                the purpose of each menu item.The message
-                WM_MENUSELECT is sent when the user starts browsing
-                the menu for each menu item where the mouse passes.
- Input:         Standard windows.
- Output:        The string from the resources string table is shown
- Errors:        If the string is not found nothing will be shown.
+Procedure:     MsgMenuSelect ID:1
+Purpose:       Shows in the status bar a descriptive explaation of
+the purpose of each menu item.The message
+WM_MENUSELECT is sent when the user starts browsing
+the menu for each menu item where the mouse passes.
+Input:         Standard windows.
+Output:        The string from the resources string table is shown
+Errors:        If the string is not found nothing will be shown.
 ------------------------------------------------------------------------*/
 LRESULT MsgMenuSelect(HWND hwnd, UINT uMessage, WPARAM wparam, LPARAM lparam)
 {
-    static char szBuffer[256];
-    UINT   nStringID = 0;
-    UINT   fuFlags = GET_WM_MENUSELECT_FLAGS(wparam, lparam) & 0xffff;
-    UINT   uCmd    = GET_WM_MENUSELECT_CMD(wparam, lparam);
-    HMENU  hMenu   = GET_WM_MENUSELECT_HMENU(wparam, lparam);
-
-    szBuffer[0] = 0;                            // First reset the buffer
-    if (fuFlags == 0xffff && hMenu == NULL)     // Menu has been closed
-        nStringID = 0;
-
-    else if (fuFlags & MFT_SEPARATOR)           // Ignore separators
-        nStringID = 0;
-
-    else if (fuFlags & MF_POPUP)                // Popup menu
-    {
-        if (fuFlags & MF_SYSMENU)               // System menu
-            nStringID = IDS_SYSMENU;
-        else
-            // Get string ID for popup menu from idPopup array.
-            nStringID = 0;
-    }  // for MF_POPUP
-    else                                        // Must be a command item
-        nStringID = uCmd;                       // String ID == Command ID
-
-    // Load the string if we have an ID
-    if (0 != nStringID)
-        LoadString(hInst, nStringID, szBuffer, sizeof(szBuffer));
-    // Finally... send the string to the status bar
-    UpdateStatusBar(szBuffer, 0, 0);
-    return 0;
+	static char szBuffer[256];
+	UINT   nStringID = 0;
+	UINT   fuFlags = GET_WM_MENUSELECT_FLAGS(wparam, lparam) & 0xffff;
+	UINT   uCmd    = GET_WM_MENUSELECT_CMD(wparam, lparam);
+	HMENU  hMenu   = GET_WM_MENUSELECT_HMENU(wparam, lparam);
+
+	szBuffer[0] = 0;                            // First reset the buffer
+	if (fuFlags == 0xffff && hMenu == NULL)     // Menu has been closed
+		nStringID = 0;
+
+	else if (fuFlags & MFT_SEPARATOR)           // Ignore separators
+		nStringID = 0;
+
+	else if (fuFlags & MF_POPUP)                // Popup menu
+	{
+		if (fuFlags & MF_SYSMENU)               // System menu
+			nStringID = IDS_SYSMENU;
+		else
+			// Get string ID for popup menu from idPopup array.
+			nStringID = 0;
+	}  // for MF_POPUP
+	else                                        // Must be a command item
+		nStringID = uCmd;                       // String ID == Command ID
+
+	// Load the string if we have an ID
+	if (0 != nStringID)
+		LoadString(hInst, nStringID, szBuffer, sizeof(szBuffer));
+	// Finally... send the string to the status bar
+	UpdateStatusBar(szBuffer, 0, 0);
+	return 0;
 }
 
 /*------------------------------------------------------------------------
- Procedure:     TimerProc ID:1
- Purpose:       This procedure will be called by windows about 4
-                times a second. It will just send a message to the
-                mdi child window to look at the pipe.
- Input:
- Output:
- Errors:
+Procedure:     TimerProc ID:1
+Purpose:       This procedure will be called by windows about 4
+times a second. It will just send a message to the
+mdi child window to look at the pipe.
+Input:
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 static VOID CALLBACK TimerProc(HWND hwnd, UINT uMsg, UINT idEvent, DWORD dwTime)
 {
-   SendMessage(hwndSession, WM_TIMERTICK, 0, 0);
+	SendMessage(hwndSession, WM_TIMERTICK, 0, 0);
 }
 
 /*------------------------------------------------------------------------
- Procedure:     InitializeStatusBar ID:1
- Purpose:       Initialize the status bar
- Input:         hwndParent: the parent window
-                nrOfParts: The status bar can contain more than one
-                part. What is difficult, is to figure out how this
-                should be drawn. So, for the time being only one is
-                being used...
- Output:        The status bar is created
- Errors:
+Procedure:     InitializeStatusBar ID:1
+Purpose:       Initialize the status bar
+Input:         hwndParent: the parent window
+nrOfParts: The status bar can contain more than one
+part. What is difficult, is to figure out how this
+should be drawn. So, for the time being only one is
+being used...
+Output:        The status bar is created
+Errors:
 ------------------------------------------------------------------------*/
 void InitializeStatusBar(HWND hwndParent,int nrOfParts)
 {
-    const int cSpaceInBetween = 8;
-    int   ptArray[40];   // Array defining the number of parts/sections
-    RECT  rect;
-    HDC   hDC;
+	const int cSpaceInBetween = 8;
+	int   ptArray[40];   // Array defining the number of parts/sections
+	RECT  rect;
+	HDC   hDC;
 
-   /* * Fill in the ptArray...  */
+	/* * Fill in the ptArray...  */
 
-    hDC = GetDC(hwndParent);
-    GetClientRect(hwndParent, &rect);
+	hDC = GetDC(hwndParent);
+	GetClientRect(hwndParent, &rect);
 
-    ptArray[nrOfParts-1] = rect.right;
-    //---TODO--- Add code to calculate the size of each part of the status
-    // bar here.
+	ptArray[nrOfParts-1] = rect.right;
+	//---TODO--- Add code to calculate the size of each part of the status
+	// bar here.
 
-    ReleaseDC(hwndParent, hDC);
-    SendMessage(hWndStatusbar,
-                SB_SETPARTS,
-                nrOfParts,
-                (LPARAM)(LPINT)ptArray);
+	ReleaseDC(hwndParent, hDC);
+	SendMessage(hWndStatusbar,
+		SB_SETPARTS,
+		nrOfParts,
+		(LPARAM)(LPINT)ptArray);
 
-    UpdateStatusBar("Ready", 0, 0);
+	UpdateStatusBar("Ready", 0, 0);
 }
 
 
 /*------------------------------------------------------------------------
- Procedure:     CreateSBar ID:1
- Purpose:       Calls CreateStatusWindow to create the status bar
- Input:         hwndParent: the parent window
-                initial text: the initial contents of the status bar
- Output:
- Errors:
+Procedure:     CreateSBar ID:1
+Purpose:       Calls CreateStatusWindow to create the status bar
+Input:         hwndParent: the parent window
+initial text: the initial contents of the status bar
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 static BOOL CreateSBar(HWND hwndParent,char *initialText,int nrOfParts)
 {
-    hWndStatusbar = CreateStatusWindow(WS_CHILD | WS_VISIBLE | WS_BORDER|SBARS_SIZEGRIP,
-                                       initialText,
-                                       hwndParent,
-                                       IDM_STATUSBAR);
-    if(hWndStatusbar)
-    {
-        InitializeStatusBar(hwndParent,nrOfParts);
-        return TRUE;
-    }
-
-    return FALSE;
+	hWndStatusbar = CreateStatusWindow(WS_CHILD | WS_VISIBLE | WS_BORDER|SBARS_SIZEGRIP,
+		initialText,
+		hwndParent,
+		IDM_STATUSBAR);
+	if(hWndStatusbar)
+	{
+		InitializeStatusBar(hwndParent,nrOfParts);
+		return TRUE;
+	}
+
+	return FALSE;
 }
 /*------------------------------------------------------------------------
- Procedure:     InitApplication ID:1
- Purpose:       Registers two window classes: the "inria" window
-                class with the main window, and the mdi child
-                window's window class.
- Input:
- Output:
- Errors:
+Procedure:     InitApplication ID:1
+Purpose:       Registers two window classes: the "inria" window
+class with the main window, and the mdi child
+window's window class.
+Input:
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 static BOOL InitApplication(void)
 {
-        WNDCLASS wc;
-
-        memset(&wc,0,sizeof(WNDCLASS));
-        wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS ;
-        wc.lpfnWndProc = (WNDPROC)MainWndProc;
-        wc.hInstance = hInst;
-        wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1);
-        wc.lpszClassName = "inriaWndClass";
-        wc.lpszMenuName = MAKEINTRESOURCE(IDMAINMENU);
-        wc.hCursor = LoadCursor(NULL,IDC_ARROW);
-        wc.hIcon = LoadIcon(hInst,MAKEINTRESOURCE(OCAML_ICON));
-        if (!RegisterClass(&wc))
-                return 0;
-        wc.style         = 0;
-        wc.lpfnWndProc   = (WNDPROC)MdiChildWndProc;
-        wc.cbClsExtra    = 0;
-        wc.cbWndExtra    = 20;
-        wc.hInstance     = hInst;                      // Owner of this class
-        wc.hIcon         = LoadIcon(hInst, MAKEINTRESOURCE(OCAML_ICON));
-        wc.hCursor       = LoadCursor(NULL, IDC_ARROW);
-        wc.hbrBackground = (HBRUSH)(COLOR_WINDOW + 1); // Default color
-        wc.lpszMenuName  = NULL;
-        wc.lpszClassName = "MdiChildWndClass";
-        if (!RegisterClass((LPWNDCLASS)&wc))
-                return FALSE;
-        return 1;
+	WNDCLASS wc;
+
+	memset(&wc,0,sizeof(WNDCLASS));
+	wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS ;
+	wc.lpfnWndProc = (WNDPROC)MainWndProc;
+	wc.hInstance = hInst;
+	wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1);
+	wc.lpszClassName = "inriaWndClass";
+	wc.lpszMenuName = MAKEINTRESOURCE(IDMAINMENU);
+	wc.hCursor = LoadCursor(NULL,IDC_ARROW);
+	wc.hIcon = LoadIcon(hInst,MAKEINTRESOURCE(OCAML_ICON));
+	if (!RegisterClass(&wc))
+		return 0;
+	wc.style         = 0;
+	wc.lpfnWndProc   = (WNDPROC)MdiChildWndProc;
+	wc.cbClsExtra    = 0;
+	wc.cbWndExtra    = 20;
+	wc.hInstance     = hInst;                      // Owner of this class
+	wc.hIcon         = LoadIcon(hInst, MAKEINTRESOURCE(OCAML_ICON));
+	wc.hCursor       = LoadCursor(NULL, IDC_ARROW);
+	wc.hbrBackground = (HBRUSH)(COLOR_WINDOW + 1); // Default color
+	wc.lpszMenuName  = NULL;
+	wc.lpszClassName = "MdiChildWndClass";
+	if (!RegisterClass((LPWNDCLASS)&wc))
+		return FALSE;
+	return 1;
 }
 
 /*------------------------------------------------------------------------
- Procedure:     CreateinriaWndClassWnd ID:1
- Purpose:       Creates the main window
- Input:
- Output:
- Errors:
+Procedure:     CreateinriaWndClassWnd ID:1
+Purpose:       Creates the main window
+Input:
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 HWND CreateinriaWndClassWnd(void)
 {
-        return CreateWindow("inriaWndClass","Ocaml",
-                WS_MINIMIZEBOX|WS_VISIBLE|WS_CLIPSIBLINGS|WS_CLIPCHILDREN|WS_MAXIMIZEBOX|WS_CAPTION|WS_BORDER|WS_SYSMENU|WS_THICKFRAME,
-                CW_USEDEFAULT,0,CW_USEDEFAULT,0,
-                NULL,
-                NULL,
-                hInst,
-                NULL);
+	return CreateWindow("inriaWndClass","OCamlWinPlus v1.9RC4",
+		WS_MINIMIZEBOX|WS_VISIBLE|WS_CLIPSIBLINGS|WS_CLIPCHILDREN|WS_MAXIMIZEBOX|WS_CAPTION|WS_BORDER|WS_SYSMENU|WS_THICKFRAME,
+		CW_USEDEFAULT,0,CW_USEDEFAULT,0,
+		NULL,
+		NULL,
+		hInst,
+		NULL);
 }
 
 /*------------------------------------------------------------------------
- Procedure:     MDICmdFileNew ID:1
- Purpose:       Creates a new session window. Note that multiple
-                windows with multiple sessions are possible.
- Input:
- Output:
- Errors:
+Procedure:     MDICmdFileNew ID:1
+Purpose:       Creates a new session window. Note that multiple
+windows with multiple sessions are possible.
+Input:
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 static HWND MDICmdFileNew(char *title, int show)
 {
-        HWND  hwndChild;
-        char  rgch[150];
-        static int cUntitled;
-        MDICREATESTRUCT mcs;
+	HWND  hwndChild;
+	char  rgch[150];
+	static int cUntitled;
+	MDICREATESTRUCT mcs;
+
+	if (title == NULL)
+		wsprintf(rgch,"Session%d", cUntitled++);
+	else {
+		strncpy(rgch,title,149);
+		rgch[149] = 0;
+	}
+
+	// Create the MDI child window
+
+	mcs.szClass = "MdiChildWndClass";      // window class name
+	mcs.szTitle = rgch;             // window title
+	mcs.hOwner  = hInst;            // owner
+	mcs.x       = CW_USEDEFAULT;    // x position
+	mcs.y       = CW_USEDEFAULT;    // y position
+	mcs.cx      = CW_USEDEFAULT;    // width
+	mcs.cy      = CW_USEDEFAULT;    // height
+	mcs.style   = 0;                // window style
+	mcs.lParam  = 0;                // lparam
+
+	hwndChild = (HWND) SendMessage(hwndMDIClient,
+		WM_MDICREATE,
+		0,
+		(LPARAM)(LPMDICREATESTRUCT) &mcs);
+
+	if (hwndChild != NULL && show)
+		ShowWindow(hwndChild, SW_SHOW);
+
+	return hwndChild;
+}
+static HWND CreateMdiClient(HWND hwndparent)
+{
+	CLIENTCREATESTRUCT ccs = {0};
+	HWND hwndMDIClient;
+	int icount = GetMenuItemCount(GetMenu(hwndparent));
+
+	// Find window menu where children will be listed
+	ccs.hWindowMenu  = GetSubMenu(GetMenu(hwndparent), icount-2);
+	ccs.idFirstChild = IDM_WINDOWCHILD;
+
+	// Create the MDI client filling the client area
+	hwndMDIClient = CreateWindow("mdiclient",
+		NULL,
+		WS_CHILD | WS_CLIPCHILDREN | WS_VSCROLL |
+		WS_HSCROLL,
+		0, 0, 0, 0,
+		hwndparent,
+		(HMENU)0xCAC,
+		hInst,
+		(LPVOID)&ccs);
+
+	ShowWindow(hwndMDIClient, SW_SHOW);
+
+	return hwndMDIClient;
+}
 
-        if (title == NULL)
-                wsprintf(rgch,"Session%d", cUntitled++);
-        else {
-                strncpy(rgch,title,149);
-                rgch[149] = 0;
-        }
+void GotoEOF(void)
+{
+	HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
+	int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
+	int lineindex = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0);
+	int lastLineLength = SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0);
 
-        // Create the MDI child window
+	lineindex += lastLineLength;
+	SendMessage(hEdit,EM_SETSEL,lineindex,lineindex);
+}
 
-        mcs.szClass = "MdiChildWndClass";      // window class name
-        mcs.szTitle = rgch;             // window title
-        mcs.hOwner  = hInst;            // owner
-        mcs.x       = CW_USEDEFAULT;    // x position
-        mcs.y       = CW_USEDEFAULT;    // y position
-        mcs.cx      = CW_USEDEFAULT;    // width
-        mcs.cy      = CW_USEDEFAULT;    // height
-        mcs.style   = 0;                // window style
-        mcs.lParam  = 0;                // lparam
+/*------------------------------------------------------------------------
+Procedure:     GotoPrompt ID:1
+Author:		   Chris Watford watford@uiuc.edu
+Purpose:       Puts the cursor on the prompt line right after the '# '
+Input:
+Output:
+Errors:
+------------------------------------------------------------------------*/
+void GotoPrompt(void)
+{
+	HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
+	int lineindex = SendMessage(hEdit,EM_LINEINDEX,LastPromptPosition.line,0)+2;
+	SendMessage(hEdit,EM_SETSEL,lineindex,lineindex);
+}
 
-        hwndChild = (HWND) SendMessage(hwndMDIClient,
-                                       WM_MDICREATE,
-                                       0,
-                                       (LPARAM)(LPMDICREATESTRUCT) &mcs);
+int GetCurLineIndex(HWND hEdit)
+{
+	return SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0);
+}
 
-        if (hwndChild != NULL && show)
-                ShowWindow(hwndChild, SW_SHOW);
+int GetNumberOfLines(HWND hEdit)
+{
+	return SendMessage(hEdit,EM_GETLINECOUNT,0,0);
+}
 
-        return hwndChild;
+static int GetWordUnderCursor(HWND hwndEditControl,char *buf,int len)
+{
+	char *line,*p,*pstart,*pend;
+	int lineidx,start,end,length,offset,cursorpos,startingChar;
+
+	SendMessage(hwndEditControl,EM_GETSEL,(WPARAM)&start,(LPARAM)&end);
+	lineidx = SendMessage(hwndEditControl,EM_EXLINEFROMCHAR,0,start);
+	startingChar = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0);
+	start -= startingChar;
+	end -= startingChar;
+	lineidx = SendMessage(hwndEditControl,EM_LINEFROMCHAR,start,0);
+	length = SendMessage(hwndEditControl,EM_LINELENGTH,lineidx,0);
+	offset = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0);
+	line = SafeMalloc(length+1);
+	memset(line,0,length+1);
+	*(unsigned short *)line = length;
+	SendMessage(hwndEditControl,EM_GETLINE,lineidx,(LPARAM)line);
+	cursorpos = start-offset;
+	p = line + cursorpos;
+	pstart = p;
+	while (*pstart
+		&& *pstart != ' '
+		&& *pstart != '\t'
+		&& *pstart != '('
+		&& pstart > line)
+		pstart--;
+	pend = p;
+	while (*pend
+		&& *pend != ' '
+		&& *pend != '\t'
+		&& *pend != '('
+		&& pend < line + length)
+		pend++;
+	if (*pstart == ' ' || *pstart == '\t')
+		pstart++;
+	if (*pend == ' ' || *pend == '\t')
+		pend--;
+	memcpy(buf,pstart,1+pend-pstart);
+	buf[pend-pstart] = 0;
+	free(line);
+	return 1;
 }
-static HWND CreateMdiClient(HWND hwndparent)
+
+/*------------------------------------------------------------------------
+Procedure:     GetLastLine ID:1
+Purpose:       Gets the data in the line containing the cursor to
+			   the interpreter.
+Input:         The edit control window handle
+Output:        None explicit
+Errors:        None
+------------------------------------------------------------------------*/
+char* GetLastLine(HWND hEdit)
 {
-    CLIENTCREATESTRUCT ccs = {0};
-    HWND hwndMDIClient;
-    int icount = GetMenuItemCount(GetMenu(hwndparent));
+	int curline = GetCurLineIndex(hEdit);
+	char *linebuffer = (char*)SafeMalloc(2048*sizeof(char));
+	int n;
+	int linescount = GetNumberOfLines(hEdit);
 
-    // Find window menu where children will be listed
-    ccs.hWindowMenu  = GetSubMenu(GetMenu(hwndparent), icount-2);
-    ccs.idFirstChild = IDM_WINDOWCHILD;
+	*(unsigned short *)linebuffer = 2047;
+	n = SendMessage(hEdit,EM_GETLINE,curline,(LPARAM)linebuffer);
 
-    // Create the MDI client filling the client area
-    hwndMDIClient = CreateWindow("mdiclient",
-                                 NULL,
-                                 WS_CHILD | WS_CLIPCHILDREN | WS_VSCROLL |
-                                 WS_HSCROLL,
-                                 0, 0, 0, 0,
-                                 hwndparent,
-                                 (HMENU)0xCAC,
-                                 hInst,
-                                 (LPVOID)&ccs);
+	if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ') {
+		n -= 2;
+		memmove(linebuffer, linebuffer+2, n);
+	}
 
-    ShowWindow(hwndMDIClient, SW_SHOW);
+	linebuffer[n] = '\0';
 
-    return hwndMDIClient;
+	return linebuffer;
 }
 
-void GotoEOF(void)
+void DoHelp(HWND hwnd)
 {
-        HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
-        int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
-        int lineindex = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0);
-        int lastLineLength = SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0);
-
-        lineindex += lastLineLength;
-        SendMessage(hEdit,EM_SETSEL,lineindex,lineindex);
+	char word[256];
+	GetWordUnderCursor(hwnd,word,sizeof(word));
+	MessageBox(NULL,word,"Aide pour:",MB_OK);
 }
 
-int GetCurLineIndex(HWND hEdit)
+/*------------------------------------------------------------------------
+Procedure:     RewriteCurrentEditBuffer ID:1
+Purpose:       Rewrites what is at the prompt with the current contents of
+			   the edit buffer
+Input:         None
+Output:        None explicit
+Errors:        None
+------------------------------------------------------------------------*/
+void RewriteCurrentEditBuffer(void)
 {
-        return SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0);
+	// get the editbox's handle
+	HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
+
+	// calculate what to highlight
+	int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
+	int lineindex = SendMessage(hEdit,EM_LINEINDEX,LastPromptPosition.line,0) + 2;
+	int lastLine = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0) + SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0) + 100;
+
+	// delete the current text
+	SendMessage(hEdit, EM_SETSEL, (WPARAM)lineindex, (LPARAM)lastLine);
+	SendMessage(hEdit, EM_REPLACESEL, (WPARAM)TRUE, (LPARAM)"");
+
+	{
+		// loop through each line in the edit buffer and add it to the control
+		LineList* line = CurrentEditBuffer->Lines;
+		for(; line != NULL; line = line->Next)
+		{
+			// if there is a line before me, add a newline
+			if(line->Prev != NULL)
+				SendMessage(hEdit, EM_REPLACESEL, (WPARAM)TRUE, (LPARAM)"\r\n");
+
+			// add the line
+			SendMessage(hEdit, EM_REPLACESEL, (WPARAM)TRUE, (LPARAM)line->Text);
+		}
+	}
 }
 
-int GetNumberOfLines(HWND hEdit)
+/*------------------------------------------------------------------------
+Procedure:     RefreshCurrentEditBuffer ID:1
+Purpose:       Rewrites what is in the CurrentEditBuffer with what is
+			   actually there
+Input:         None
+Output:        None explicit
+Errors:        None
+------------------------------------------------------------------------*/
+void RefreshCurrentEditBuffer(void)
 {
-        return SendMessage(hEdit,EM_GETLINECOUNT,0,0);
+	// get the editbox's handle
+	HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER);
+
+	// get the last line index
+	int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0) - 1;
+	int i = 0, n = 0;
+
+	// where to hold the line we grab
+	char *linebuffer = (char*)SafeMalloc(2048*sizeof(char));
+	*(unsigned short *)linebuffer = 2047;
+
+	editbuffer_destroy(CurrentEditBuffer);
+	CurrentEditBuffer = editbuffer_new();
+
+	// loop through each line updating or adding it to the current edit buffer
+	for( ; (i + LastPromptPosition.line) <= linesCount; i++)
+	{
+		n = SendMessage(hEdit, EM_GETLINE, (i + LastPromptPosition.line), (LPARAM)linebuffer);
+
+		if ((n >= 2) && (linebuffer[0] == '#') && (linebuffer[1] == ' ')) {
+			n -= 2;
+			memmove(linebuffer, linebuffer+2, n);
+		}
+
+		linebuffer[n] = '\0';
+
+		{	// remove line breaks and feeds
+			char* ln = linebuffer;
+
+			while((*ln) != 0)
+			{
+				switch((*ln))
+				{
+					case '\r':
+					case '\n':
+						(*ln) = ' ';
+				}
+
+				ln++;
+			}
+		}
+
+		editbuffer_addline(CurrentEditBuffer, linebuffer);
+	}
 }
 
-static int GetWordUnderCursor(HWND hwndEditControl,char *buf,int len)
+/*------------------------------------------------------------------------
+Procedure:     NextHistoryEntry ID:1
+Purpose:       Scrolls to the next history entry
+Input:         None
+Output:        None explicit
+Errors:        None
+--------------------------------------------------------------------------
+Edit History:
+	17 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added this as a helper function
+	18 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Corrected doubly linked list problems
+------------------------------------------------------------------------*/
+void NextHistoryEntry(void)
 {
-    char *line,*p,*pstart,*pend;
-    int lineidx,start,end,length,offset,cursorpos,startingChar;
-
-    SendMessage(hwndEditControl,EM_GETSEL,(WPARAM)&start,(LPARAM)&end);
-    lineidx = SendMessage(hwndEditControl,EM_EXLINEFROMCHAR,0,start);
-    startingChar = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0);
-    start -= startingChar;
-    end -= startingChar;
-        lineidx = SendMessage(hwndEditControl,EM_LINEFROMCHAR,start,0);
-    length = SendMessage(hwndEditControl,EM_LINELENGTH,lineidx,0);
-    offset = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0);
-    line = SafeMalloc(length+1);
-    memset(line,0,length+1);
-    *(unsigned short *)line = length;
-    SendMessage(hwndEditControl,EM_GETLINE,lineidx,(LPARAM)line);
-    cursorpos = start-offset;
-    p = line + cursorpos;
-    pstart = p;
-    while (*pstart
-            && *pstart != ' '
-            && *pstart != '\t'
-            && *pstart != '('
-            && pstart > line)
-            pstart--;
-    pend = p;
-    while (*pend
-            && *pend != ' '
-            && *pend != '\t'
-            && *pend != '('
-            && pend < line + length)
-            pend++;
-    if (*pstart == ' ' || *pstart == '\t')
-            pstart++;
-    if (*pend == ' ' || *pend == '\t')
-            pend--;
-    memcpy(buf,pstart,1+pend-pstart);
-    buf[pend-pstart] = 0;
-        free(line);
-    return 1;
+	// out of bounds, put it back into bounds
+	if(historyEntry == NULL && History == NULL)
+	{
+		return;
+	} else if (historyEntry == NULL && History != NULL) {
+		historyEntry = History;
+	} else {
+		if(historyEntry->Next == NULL)
+			return;
+
+		historyEntry = historyEntry->Next;
+	}
+
+	// if its valid
+	if(historyEntry != NULL)
+	{
+		// copy the history entry to a new buffer
+		EditBuffer* newBuf = editbuffer_copy(historyEntry->Statement);
+
+		// destroy the old buffer
+		editbuffer_destroy(CurrentEditBuffer);
+
+		// setup the current one to the copy
+		CurrentEditBuffer = newBuf;
+
+		// rewrite the old one and go to the prompt
+		RewriteCurrentEditBuffer();
+		GotoPrompt();
+	}
 }
 
-void DoHelp(HWND hwnd)
+/*------------------------------------------------------------------------
+Procedure:     PrevHistoryEntry ID:1
+Purpose:       Scrolls to the previous history entry
+Input:         None
+Output:        None explicit
+Errors:        None
+--------------------------------------------------------------------------
+Edit History:
+	17 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added this as a helper function
+	18 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Corrected doubly linked list problems
+------------------------------------------------------------------------*/
+void PrevHistoryEntry(void)
 {
-    char word[256];
-    GetWordUnderCursor(hwnd,word,sizeof(word));
-        MessageBox(NULL,word,"Aide pour:",MB_OK);
+	// out of bounds, put it back into bounds
+	if(historyEntry == NULL || History == NULL)
+	{
+		return;
+	} else {
+		if(historyEntry->Prev == NULL)
+			return;
+
+		historyEntry = historyEntry->Prev;
+	}
+
+	// if its valid
+	if(historyEntry != NULL)
+	{
+		// copy the history entry to a new buffer
+		EditBuffer* newBuf = editbuffer_copy(historyEntry->Statement);
+
+		// destroy the old buffer
+		editbuffer_destroy(CurrentEditBuffer);
+
+		// setup the current one to the copy
+		CurrentEditBuffer = newBuf;
+
+		// rewrite the old one and go to the prompt
+		RewriteCurrentEditBuffer();
+		GotoPrompt();
+	}
 }
 
-
+/*------------------------------------------------------------------------
+Procedure:     SubClassEdit ID:1
+Purpose:       Handles messages to the editbox
+Input:         
+Output:        
+Errors:
+--------------------------------------------------------------------------
+Edit History:
+	14 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Setup handler for up and down arrows
+	15 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Setup framework for history on up arrow
+		- Saves lines you move off of in the edit buffer
+	16 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Proper handling of newline message finished
+		- Fixed ENTER on middle of interior line, moves cursor to the end
+		  and sends the line
+		- Setup the copying and destroying of the old buffer
+		- Included buffer rewrite
+	17 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added C-p/C-n support
+		- Changed UpArrow to C-UpArrow so as to not confuse users
+	18 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added Left and Right arrow line saving
+		- Added backspace and delete line saving and removing
+		- Fixed history scrolling
+	21 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Fixed pasting errors associated with lines being out of bounds
+		  for the buffer
+		- Added error handling, possibly able to handle it diff down the
+		  line
+		- Removed C-Up/C-Dn for history scrolling, buggy at best on my
+		  machine
+------------------------------------------------------------------------*/
 static LRESULT CALLBACK SubClassEdit(HWND hwnd, UINT msg, WPARAM mp1, LPARAM mp2)
 {
-        LRESULT r;
-        int postit=0,nl;
-        if (msg == WM_CHAR && mp1 == '\r') {
-                if (!busy) {
-                        CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-                        CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-                        r =  GetCurLineIndex(hwnd);
-                        nl = GetNumberOfLines(hwnd);
-                        if (r != nl-1) {
-                                PostMessage(GetParent(hwnd),WM_NEWLINE,0,0);
-                                return 0;
-                        }
-                        postit = 1;
-                }
-
-        }
-        else if (msg == WM_KEYDOWN && mp1 == VK_F1) {
-                DoHelp(hwnd);
-        }
-        r = CallWindowProc(lpEProc, hwnd, msg, mp1, mp2);
-        if (postit)
-                PostMessage(GetParent(hwnd),WM_NEWLINE,0,0);
-        return r;
+	LRESULT r;
+	int postit=0,nl;
+
+	if (msg == WM_CHAR && mp1 == '\r') {
+		if (!busy) {
+			r =  GetCurLineIndex(hwnd);
+			nl = GetNumberOfLines(hwnd);
+
+			// if we're not the last line
+			if (r != nl-1)
+			{
+				// update or add us, we might not have any lines in the edit buffer
+				editbuffer_updateoraddline(CurrentEditBuffer, r-LastPromptPosition.line, GetLastLine(hwnd));
+
+				// scroll to the end, add CrLf then post the newline message
+				GotoEOF();
+				AddStringToControl("\r\n");
+				PostMessage(GetParent(hwnd),WM_NEWLINE,0,0);
+				return 0;
+			}
+
+			CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
+			CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
+
+			postit = 1;
+		}
+
+	}
+	else if (msg == WM_CHAR && mp1 == (char)0x08) {
+		int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
+		int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
+		int nextline = 0;
+		int curpoint = 0;
+
+		SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
+		nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint - 1),0);
+
+		if(curpoint <= lineindex)
+		{
+			return 0;
+		} else if(nextline != curline) {
+			// delete the line we're on
+
+			// grab the index
+			curline -= LastPromptPosition.line;
+
+			// kill it
+			editbuffer_removeline(CurrentEditBuffer, curline);
+		}
+	}
+	else if (msg == WM_KEYDOWN && mp1 == VK_F1) {
+		DoHelp(hwnd);
+	}
+	else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && mp1 == VK_UP) {
+		int curline = GetCurLineIndex(hwnd);
+
+		/*if((msg == WM_KEYDOWN) && (GetKeyState(VK_CONTROL) && 0x8000))
+		{	// go forward once in history
+			NextHistoryEntry();
+			return 0;
+		} else */
+		if((curline > LastPromptPosition.line) && (curline <= (LastPromptPosition.line + CurrentEditBuffer->LineCount)))
+		{
+			// update current line
+			if (msg == WM_KEYDOWN)
+			{
+				int lineidx = (curline - LastPromptPosition.line);
+
+				CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
+				CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
+				
+				// we may have to add this line, otherwise update it
+				editbuffer_updateoraddline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
+			}
+		} else {
+			return 0;
+		}
+	}
+	else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_LEFT)) {
+		int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
+		int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
+		int nextline = 0;
+		int curpoint = 0;
+
+		SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
+		nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint - 1),0);
+
+		if(curpoint <= lineindex)
+		{	// no left arrow to the left of the prompt
+			return 0;
+		} else if(nextline != curline) {
+			// update current line
+			if (msg == WM_KEYDOWN)
+			{
+				int lineidx = (curline - LastPromptPosition.line);
+
+				CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
+				CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
+				
+				// we may have to add this line, otherwise update it
+				editbuffer_updateoraddline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
+
+				CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_HOME,1);
+				CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_HOME,1);
+			}
+		}
+	}
+	else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_DOWN)) {
+		int curline = GetCurLineIndex(hwnd);
+		
+		/*if((msg == WM_KEYDOWN) && (GetKeyState(VK_CONTROL) && 0x8000))
+		{	// go back once in history
+			PrevHistoryEntry();
+			return 0;
+		} else*/
+		if((curline >= LastPromptPosition.line) && (curline < (LastPromptPosition.line + CurrentEditBuffer->LineCount)))
+		{
+			// We don't post the newline, but instead update the current line
+			if (msg == WM_KEYDOWN)
+			{
+				int lineidx = (curline - LastPromptPosition.line);
+
+				CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
+				CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
+				
+				editbuffer_updateline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
+			}
+		} else {
+			return 0;
+		}
+	}
+	else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_RIGHT)) {
+		int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 1;
+		int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
+		int nextline = 0;
+		int curpoint = 0;
+
+		SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
+		nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint + 2),0);
+
+		if(curpoint <= lineindex)
+		{	// no movement behind the prompt
+			return 0;
+		} else if((nextline != curline) && (msg = WM_KEYDOWN)) {
+			int lineidx = (curline - LastPromptPosition.line);
+
+			CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
+			CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
+			
+			editbuffer_updateline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
+		}
+	}
+	else if ((msg == WM_KEYDOWN) && (mp1 == VK_PRIOR) && (GetKeyState(VK_CONTROL) && 0x8000)) {
+		// C-p
+		NextHistoryEntry();
+		return 0;
+	}
+	else if ((msg == WM_KEYDOWN) && (mp1 == VK_NEXT) && (GetKeyState(VK_CONTROL) && 0x8000)) {
+		// C-n
+		PrevHistoryEntry();
+		return 0;
+	}
+	else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_DELETE)) {
+		// see if we're the last char on the line, if so delete the next line
+		// don't allow deleting left of the prompt
+		int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
+		int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
+		int nextline = 0;
+		int curpoint = 0;
+
+		SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
+		nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint + 2),0);
+
+		if(curpoint < lineindex)
+		{	// no chomping behind the prompt
+			return 0;
+		} else if(nextline != curline) {
+			// deleting
+			// grab the next line index
+			curline -= LastPromptPosition.line;
+
+			// kill it
+			editbuffer_removeline(CurrentEditBuffer, curline+1);
+		}
+	}
+	else if (msg == WM_PASTE) {
+		// if they paste text, allow it
+		r = CallWindowProc(lpEProc, hwnd, msg, mp1, mp2);
+
+		// update the current edit buffer
+		RefreshCurrentEditBuffer();
+
+		return r;
+	}
+
+	// handle errors
+	switch(msg)
+	{
+		case WM_SYNTAXERROR:
+		case WM_ILLEGALCHAR:
+		case WM_UNBOUNDVAL:
+			{	// currently I handle them all the same
+				// get the start of the line
+				int start = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
+
+				// get the statement that error'd
+				NextHistoryEntry();
+
+				// tell the history that the last line errored
+				if(History != NULL)
+					if(History->Statement != NULL)
+						History->Statement->isCorrect = FALSE;
+
+				// highlight the offending chars
+				SendMessage(hwnd,EM_SETSEL,(WPARAM)(start + mp1), (LPARAM)(start + mp2));
+				
+				return 0;
+			}
+	}
+
+	r = CallWindowProc(lpEProc, hwnd, msg, mp1, mp2);
+
+	if (postit)
+		PostMessage(GetParent(hwnd),WM_NEWLINE,0,0);
+
+	return r;
 }
 
 static void SubClassEditField(HWND hwnd)
 {
-        if (lpEProc == NULL) {
-                lpEProc = (WNDPROC) GetWindowLong(hwnd, GWL_WNDPROC);
-        }
-        SetWindowLong(hwnd, GWL_WNDPROC, (DWORD) SubClassEdit);
+	if (lpEProc == NULL) {
+		lpEProc = (WNDPROC) GetWindowLong(hwnd, GWL_WNDPROC);
+	}
+	SetWindowLong(hwnd, GWL_WNDPROC, (DWORD) SubClassEdit);
 }
 
-void AddToHistory(char *text)
+/*------------------------------------------------------------------------
+Procedure:     SendLastLine ID:1
+Purpose:       Sends the data in the line containing the cursor to
+the interpreter. If this is NOT the last line, copy
+the line to the end of the text.
+Input:         The edit control window handle
+Output:        None explicit
+Errors:        None
+
+REMOVED!
+------------------------------------------------------------------------*/
+void SendLastLine(HWND hEdit)
 {
-        HISTORYLINE *newLine;
-
-        while (*text == ' ')
-                text++; // skip leading blanks
-        if (*text == 0)
-                return;
-        if (History && !strstr(History->Text,";;")) {
-                char *p = History->Text;
-                int len = strlen(p)+strlen(text) + 1 + 1; // space and zero terminator
-                History->Text = SafeMalloc(len);
-                strcpy(History->Text,p);
-                strcat(History->Text," ");
-                strcat(History->Text,text);
-                free(p);
-                return;
-        }
-        newLine = SafeMalloc(sizeof(HISTORYLINE));
-        newLine->Next = History;
-        newLine->Text = SafeMalloc(strlen(text)+1);
-        strcpy(newLine->Text,text);
-        History = newLine;
+/*	int curline = GetCurLineIndex(hEdit);
+	char *p,linebuffer[2048];
+	int n;
+	int linescount = GetNumberOfLines(hEdit);
+
+	*(unsigned short *)linebuffer = sizeof(linebuffer)-1;
+	if (curline != linescount-1)
+		n = SendMessage(hEdit,EM_GETLINE,curline,(LPARAM)linebuffer);
+	else
+		n = SendMessage(hEdit,EM_GETLINE,curline-1,(LPARAM)linebuffer);
+	if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ') {
+		n -= 2;
+		memmove(linebuffer, linebuffer+2, n);
+	}
+	linebuffer[n] = 0;
+
+	// Record user input!
+	AddToHistory(linebuffer);
+	linebuffer[n] = '\n';
+	linebuffer[n+1] = 0;
+	WriteToPipe(linebuffer);
+	if (curline != linescount-1) {
+		// Copy the line sent to the end of the text
+		p = strrchr(linebuffer,'\n');
+		if (p) {
+			*p = 0;
+		}
+		busy = 1;
+		AddLineToControl(linebuffer);
+		busy = 0;
+	}*/
 }
 
-char *GetHistoryLine(int n)
+/*------------------------------------------------------------------------
+Procedure:     SendLastEditBuffer ID:1
+Author:		   Chris Watford watford@uiuc.edu
+Purpose:       Sends an edit buffer to the pipe
+Input:
+Output:
+Errors:
+--------------------------------------------------------------------------
+Edit History:
+	15 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Sends line to the pipe and adds newline to the end
+------------------------------------------------------------------------*/
+void SendLastEditBuffer(HWND hwndChild)
 {
-        HISTORYLINE *rvp = History;
-        int i;
+	char* line = editbuffer_getasbuffer(CurrentEditBuffer);
+	int l = strlen(line);
+	char* linebuffer = (char*)SafeMalloc(l+2);
+
+	// save current edit buffer to history and create a new blank edit buffer
+	CurrentEditBuffer->isCorrect = TRUE;
+	AddToHistory(CurrentEditBuffer);
+	CurrentEditBuffer = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
+	CurrentEditBuffer->LineCount = 0;
+	CurrentEditBuffer->Lines = NULL;
+
+	// add the newline to the end
+	strncpy(linebuffer, line, l);
+	linebuffer[l] = '\n';
+	linebuffer[l+1] = '\0';
+
+	// save line to the pipe
+	WriteToPipe(linebuffer);
+}
 
-        for (i=0; i<n; i++) {
-                rvp = rvp->Next;
-        }
-        if (rvp)
-                return &rvp->Text[0];
-        else
-                return "";
+/*------------------------------------------------------------------------
+Procedure:     SendingFullCommand ID:1
+Author:		   Chris Watford watford@uiuc.edu
+Purpose:       Returns if the command being sent 
+Input:         The edit control window handle
+Output:        None explicit
+Errors:        None
+--------------------------------------------------------------------------
+Edit History:
+	13 Oct  2003 - Chris Watford watford@uiuc.edu
+		- Solved the error when you have a malformed comment in the buffer
+------------------------------------------------------------------------*/
+BOOL SendingFullCommand(void)
+{
+	// if there is a ;; on the line, return true
+	char *line = editbuffer_getasline(CurrentEditBuffer);
+	char *firstComment = strstr(line, "(*"), *firstSemiColonSemiColon = strstr(line, ";;");
+
+	// easy case :D
+	if(firstSemiColonSemiColon == NULL)
+	{
+		free(line);
+		return FALSE;
+	}
+
+	// if there are no comments
+	if(firstComment == NULL)
+	{
+		BOOL r = (firstSemiColonSemiColon != NULL);
+		free(line);
+		return r;
+	} else {
+		// we have to search through finding all comments
+
+		// a neat little trick we can do is compare the point at which
+		// the ;; is and where the first (* can be found, if the ;; is
+		// before the (* ocaml.exe ignores the comment
+		if((unsigned int)firstSemiColonSemiColon < (unsigned int)firstComment)
+		{
+			free(line);
+			return TRUE;
+		} else {
+			// time to search and find if the endline is inside a comment or not
+			// start at the first comment, and move forward keeping track of the
+			// nesting level, if the nest level is 0, i.e. outside a comment
+			// and we find the ;; return TRUE immediately, otherwise keep searching
+			// if we end with a nest level >0 return FALSE
+
+			char *c = firstComment+2; // firstComment[0] is the '(', firstComment[1] is the '*'
+			int nestLevel = 1; // we have a (*
+
+			// in-comment determiner loop
+			while(c[0] != '\0')
+			{
+				// are we an endline
+				if((c[0] == ';') && (c[1] == ';'))
+				{
+					// if we are NOT in a comment, its a full line
+					if(nestLevel <= 0)
+					{
+						free(line);
+						return TRUE;
+					}
+				}
+
+				// are we in a comment?
+				if((c[0] == '(') && (c[1] == '*'))
+				{
+					nestLevel++;
+
+					// watch out we may go past the end
+					if(c[2] == '\0')
+					{
+						free(line);
+						return FALSE;
+					}
+
+					// c needs to advance past the *, cause (*) is NOT the start/finish of a comment
+					c++;
+				}
+
+				// adjust the nesting down a level
+				if((c[0] == '*') && (c[1] == ')'))
+					nestLevel--;
+
+				// next char
+				c++;
+			}
+
+			// not a full line
+			free(line);
+			return FALSE;
+		}
+	}
+
+	// weird case ;)
+	free(line);
+	return FALSE;
 }
 
 /*------------------------------------------------------------------------
- Procedure:     SendLastLine ID:1
- Purpose:       Sends the data in the line containing the cursor to
-                the interpreter. If this is NOT the last line, copy
-                the line to the end of the text.
- Input:         The edit control window handle
- Output:        None explicit
- Errors:        None
+Procedure:     AppendToEditBuffer ID:1
+Author:		   Chris Watford watford@uiuc.edu
+Purpose:       Add a line to the edit buffer
+Input:		   Handle of the edit control
+Output:
+Errors:
 ------------------------------------------------------------------------*/
-void SendLastLine(HWND hEdit)
+void AppendToEditBuffer(HWND hEdit)
 {
-        int curline = GetCurLineIndex(hEdit);
-        char *p,linebuffer[2048];
-        int n;
-        int linescount = GetNumberOfLines(hEdit);
-
-        *(unsigned short *)linebuffer = sizeof(linebuffer)-1;
-        if (curline != linescount-1)
-          n = SendMessage(hEdit,EM_GETLINE,curline,(LPARAM)linebuffer);
-        else
-          n = SendMessage(hEdit,EM_GETLINE,curline-1,(LPARAM)linebuffer);
-        if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ') {
-          n -= 2;
-          memmove(linebuffer, linebuffer+2, n);
-        }
-        linebuffer[n] = 0;
-        // Record user input!
-        AddToHistory(linebuffer);
-        linebuffer[n] = '\n';
-        linebuffer[n+1] = 0;
-        WriteToPipe(linebuffer);
-        if (curline != linescount-1) {
-                // Copy the line sent to the end of the text
-                p = strrchr(linebuffer,'\n');
-                if (p) {
-                        *p = 0;
-                }
-                busy = 1;
-                AddLineToControl(linebuffer);
-                busy = 0;
-        }
+	char *p = NULL, linebuffer[2048];
+	int n = 0;
+	int curline = GetCurLineIndex(hEdit);
+	int linescount = GetNumberOfLines(hEdit);
+
+	// they are passing the size of the buffer as
+	// the first 'short' in the array...
+	*(unsigned short *)linebuffer = sizeof(linebuffer)-1;
+
+	if (curline > (linescount-1))
+	{
+		n = SendMessage(hEdit, EM_GETLINE, curline, (LPARAM)linebuffer);
+	} else {
+		n = SendMessage(hEdit, EM_GETLINE, --curline, (LPARAM)linebuffer);
+	}
+
+	// correct for the prompt line
+	if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ')
+	{
+		n -= 2;
+		memmove(linebuffer, linebuffer+2, n);
+	}
+
+	linebuffer[n] = '\0';
+
+	// linebuffer now has the line to add to our edit buffer
+	editbuffer_updateoraddline(CurrentEditBuffer, (curline - LastPromptPosition.line), linebuffer);
 }
+
 /*------------------------------------------------------------------------
- Procedure:     SetLastPrompt ID:1
- Purpose:       Record the position of the last prompt ("# ") sent by
-                the interpreter. This isn't really used yet.
- Input:
- Output:
- Errors:
+Procedure:     SetLastPrompt ID:1
+Purpose:       Record the position of the last prompt ("# ") sent by
+the interpreter. This isn't really used yet.
+Input:
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 void SetLastPrompt(HWND hEdit)
 {
-        DWORD startpos,endpos;
-        SendMessage(hEdit,EM_GETSEL,(WPARAM)&startpos,(LPARAM)&endpos);
-        LastPromptPosition.line = SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0);
-        LastPromptPosition.col = startpos;
+	DWORD startpos,endpos;
+	SendMessage(hEdit,EM_GETSEL,(WPARAM)&startpos,(LPARAM)&endpos);
+	LastPromptPosition.line = SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0);
+	LastPromptPosition.col = startpos;
 }
 
 /*------------------------------------------------------------------------
- Procedure:     MdiChildWndProc ID:1
- Purpose:       The edit control is enclosed in a normal MDI window.
-                This is the window procedure for that window. When it
-                receives the WM_CREATE message, it will create the
-                edit control.
- Input:
- Output:
- Errors:
+Procedure:     MdiChildWndProc ID:1
+Purpose:       The edit control is enclosed in a normal MDI window.
+This is the window procedure for that window. When it
+receives the WM_CREATE message, it will create the
+edit control.
+Input:
+Output:
+Errors:
+--------------------------------------------------------------------------
+Edit History:
+	14 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added edit buffer and statement buffer support to the WM_NEWLINE
+		  message.
+	15 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Got it adding to the edit buffer
+	16 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Proper handling of newline message finished
+	21 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added error detection on return from ocaml interp
+	23 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Fixed prompt detection error as pointed out by Patrick Meredith
 ------------------------------------------------------------------------*/
 static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM lparam)
 {
-        HWND hwndChild;
-        RECT rc;
-        HDC hDC;
-
-        switch(msg) {
-        case WM_CREATE:
-          GetClientRect(hwnd,&rc);
-          hwndChild= CreateWindow("EDIT",
-                                  NULL,
-                                  WS_CHILD | WS_VISIBLE |
-                                  ES_MULTILINE |
-                                  WS_VSCROLL | WS_HSCROLL |
-                                  ES_AUTOHSCROLL | ES_AUTOVSCROLL,
-                                  0,
-                                  0,
-                                  (rc.right-rc.left),
-                                  (rc.bottom-rc.top),
-                                  hwnd,
-                                  (HMENU) EditControls++,
-                                  hInst,
-                                  NULL);
-          SetWindowLong(hwnd, DWL_USER, (DWORD) hwndChild);
-          SendMessage(hwndChild, WM_SETFONT, (WPARAM) ProgramParams.hFont, 0L);
-          SendMessage(hwndChild,EM_LIMITTEXT,0xffffffff,0);
-          SubClassEditField(hwndChild);
-          break;
-          // Resize the edit control
-        case WM_SIZE:
-          hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
-          MoveWindow(hwndChild, 0, 0, LOWORD(lparam), HIWORD(lparam), TRUE);
-          break;
-          // Always set the focus to the edit control.
-        case WM_SETFOCUS:
-          hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
-          SetFocus(hwndChild);
-          break;
-          // Repainting of the edit control about to happen.
-          // Set the text color and the background color
-        case WM_CTLCOLOREDIT:
-          hDC = (HDC)wparam;
-          SetTextColor(hDC,ProgramParams.TextColor);
-          SetBkColor(hDC,BackColor);
-          return (LRESULT)BackgroundBrush;
-          // Take care of erasing the background color to avoid flicker
-        case WM_ERASEBKGND:
-          GetWindowRect(hwnd,&rc);
-          hDC = (HDC)wparam;
-          FillRect(hDC,&rc,BackgroundBrush);
-          return 1;
-          // A carriage return has been pressed. Send the data to the interpreted.
-          // This message is posted by the subclassed edit field.
-        case WM_COMMAND:
-          if (LOWORD(wparam) >= IDEDITCONTROL && LOWORD(wparam) < IDEDITCONTROL+5) {
-            switch (HIWORD(wparam)) {
-            case EN_ERRSPACE:
-            case EN_MAXTEXT:
-              ResetText();
-              break;
-            }
-          }
-          break;
-        case WM_NEWLINE:
-          if (busy)
-            break;
-          hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
-          SendLastLine(hwndChild);
-          break;
-          // The timer will call us 4 times a second. Look if the interpreter
-          // has written something in its end of the pipe.
-        case WM_TIMERTICK:
-          hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
-          if (ReadToLineBuffer()) {
-            char *p;
-                                // Ok we read something. Display it.
-            AddLineBuffer();
-            p = strrchr(lineBuffer,'\r');
-            if (p && !strcmp(p,"\r\n# ")) {
-              if (p[4] == 0) {
-                SetLastPrompt(hwndChild);
-              }
-            }
-
-          }
-          break;
-
-        }
-        return DefMDIChildProc(hwnd, msg, wparam, lparam);
+	HWND hwndChild;
+	RECT rc;
+	HDC hDC;
+
+	switch(msg) {
+		case WM_CREATE:
+			GetClientRect(hwnd,&rc);
+			hwndChild= CreateWindow("EDIT",
+				NULL,
+				WS_CHILD | WS_VISIBLE |
+				ES_MULTILINE |
+				WS_VSCROLL | WS_HSCROLL |
+				ES_AUTOHSCROLL | ES_AUTOVSCROLL,
+				0,
+				0,
+				(rc.right-rc.left),
+				(rc.bottom-rc.top),
+				hwnd,
+				(HMENU) EditControls++,
+				hInst,
+				NULL);
+			SetWindowLong(hwnd, DWL_USER, (DWORD) hwndChild);
+			SendMessage(hwndChild, WM_SETFONT, (WPARAM) ProgramParams.hFont, 0L);
+			SendMessage(hwndChild,EM_LIMITTEXT,0xffffffff,0);
+			SubClassEditField(hwndChild);
+			break;
+			// Resize the edit control
+		case WM_SIZE:
+			hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
+			MoveWindow(hwndChild, 0, 0, LOWORD(lparam), HIWORD(lparam), TRUE);
+			break;
+			// Always set the focus to the edit control.
+		case WM_SETFOCUS:
+			hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
+			SetFocus(hwndChild);
+			break;
+			// Repainting of the edit control about to happen.
+			// Set the text color and the background color
+		case WM_CTLCOLOREDIT:
+			hDC = (HDC)wparam;
+			SetTextColor(hDC,ProgramParams.TextColor);
+			SetBkColor(hDC,BackColor);
+			return (LRESULT)BackgroundBrush;
+			// Take care of erasing the background color to avoid flicker
+		case WM_ERASEBKGND:
+			GetWindowRect(hwnd,&rc);
+			hDC = (HDC)wparam;
+			FillRect(hDC,&rc,BackgroundBrush);
+			return 1;
+			// A carriage return has been pressed. Send the data to the interpreted.
+			// This message is posted by the subclassed edit field.
+		case WM_COMMAND:
+			if (LOWORD(wparam) >= IDEDITCONTROL && LOWORD(wparam) < IDEDITCONTROL+5) {
+				switch (HIWORD(wparam)) {
+					case EN_ERRSPACE:
+					case EN_MAXTEXT:
+						ResetText();
+						break;
+				}
+			}
+			break;
+		case WM_NEWLINE:
+			if (busy)
+				break;
+
+			hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
+
+			// add what they wrote to the edit buffer
+			AppendToEditBuffer(hwndChild);
+
+		/** Modified by Chris Watford 14 Sept 2003, 15 Sept 2003, 16 Sept 2003 **/
+			// test if this line has an end or if it needs to be in the Edit Buffer
+			if(SendingFullCommand())
+			{
+				// send the edit buffer to the interpreter
+				//SendLastLine(hwndChild);
+				SendLastEditBuffer(hwndChild);
+				historyEntry = NULL;
+			} else {
+				AddStringToControl("  ");
+			}
+		/** End Modifications **/
+
+			break;
+			// The timer will call us 4 times a second. Look if the interpreter
+			// has written something in its end of the pipe.
+		case WM_TIMERTICK:
+		/** Modified by Chris Watford 21 Sept 2003 **/
+			hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER);
+
+			if (ReadToLineBuffer())
+			{
+				int errMsg = 0;
+				char *p, *l = lineBuffer;
+
+				// Ok we read something. Display the trimmed version
+				while(((*l) == ' ') || ((*l) == '\t') || ((*l) == '\n') || ((*l) == '\r') || ((*l) == '*'))
+					l++;
+
+				SendMessage(hwndChild,EM_REPLACESEL,0,(LPARAM)l);
+
+				// fix bug where it won't find prompt
+				p = strrchr(l, '\r');
+				if((l[0] == '#') || (p != NULL))
+				{
+					if(p != NULL)
+					{
+						if(!strcmp(p, "\r\n# "))
+						{
+							SetLastPrompt(hwndChild);
+						}
+					// solve the bug Patrick found
+					} else if((l[0] == '#') && (l[1] == ' ')) {
+						SetLastPrompt(hwndChild);
+					}
+				}
+
+				// detect syntax errors
+				if(strstr(lineBuffer, "Syntax error"))
+				{
+					errMsg = WM_SYNTAXERROR;
+				} else if(strstr(lineBuffer, "Illegal character")) {
+					errMsg = WM_ILLEGALCHAR;
+				} else if(strstr(lineBuffer, "Unbound value")) {
+					errMsg = WM_UNBOUNDVAL;
+				}
+
+				// error! error! alert alert!
+				if(errMsg > 0)
+				{
+					int len = strlen(lineBuffer);
+					char* err = (char*)SafeMalloc(len+1);
+					char *m = err, *n1 = NULL, *n2 = NULL, *nt = NULL;
+
+					// make a copy of the message
+					strncpy(err, lineBuffer, len);
+					err[len] = '\0';
+
+					// find it
+					m = strstr(err, "Characters ");
+					if(m == NULL)
+						break;
+
+					// got the start char
+					n1 = m + strlen("Characters ");
+					
+					// start looking for the end char
+					nt = strstr(n1, "-");
+					if(nt == NULL)
+						break;
+					
+					// makes n1 a valid string
+					nt[0] = '\0';
+
+					// end char is right after this
+					n2 = nt + 1;
+
+					// find the end of n2
+					nt = strstr(n2, ":");
+					if(nt == NULL)
+						break;
+
+					// makes n2 a valid string
+					nt[0] = '\0';
+
+					SendMessage(hwndChild, errMsg, (WPARAM)atoi(n1), (LPARAM)atoi(n2));
+				}
+			}
+		/** End Modifications **/
+
+			break;
+
+	}
+	return DefMDIChildProc(hwnd, msg, wparam, lparam);
 }
 
 
 /*------------------------------------------------------------------------
- Procedure:     MainWndProc ID:1
- Purpose:       Window procedure for the frame window, that contains
-                the menu. The messages handled are:
-                WM_CREATE: Creates the mdi child window
-                WM_SIZE: resizes the status bar and the mdi child
-                window
-                WM_COMMAND: Sends the command to the dispatcher
-                WM_CLOSE: If the user confirms, it exists the program
-                WM_QUITOCAML: Stops the program unconditionally.
- Input:         Standard windows callback
- Output:
- Errors:
+Procedure:     MainWndProc ID:1
+Purpose:       Window procedure for the frame window, that contains
+the menu. The messages handled are:
+WM_CREATE: Creates the mdi child window
+WM_SIZE: resizes the status bar and the mdi child
+window
+WM_COMMAND: Sends the command to the dispatcher
+WM_CLOSE: If the user confirms, it exists the program
+WM_QUITOCAML: Stops the program unconditionally.
+Input:         Standard windows callback
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 static LRESULT CALLBACK MainWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam)
 {
-        switch (msg) {
-                // Create the MDI client invisible window
-        case WM_CREATE:
-                hwndMDIClient = CreateMdiClient(hwnd);
-        TimerId = SetTimer((HWND) 0, 0, 100, (TIMERPROC) TimerProc);
-                break;
-        // Move the child windows
-        case WM_SIZE:
-                SendMessage(hWndStatusbar,msg,wParam,lParam);
-                InitializeStatusBar(hWndStatusbar,1);
-                // Position the MDI client window between the tool and status bars
-                if (wParam != SIZE_MINIMIZED) {
-                        RECT rc, rcClient;
-
-                        GetClientRect(hwnd, &rcClient);
-                        GetWindowRect(hWndStatusbar, &rc);
-                        ScreenToClient(hwnd, (LPPOINT)&rc.left);
-                        rcClient.bottom = rc.top;
-                        MoveWindow(hwndMDIClient,rcClient.left,rcClient.top,rcClient.right-rcClient.left, rcClient.bottom-rcClient.top, TRUE);
-                }
-
-                return 0;
-                // Dispatch the menu commands
-        case WM_COMMAND:
-                HandleCommand(hwnd, wParam,lParam);
-                return 0;
-                // If user confirms close
-        case WM_CLOSE:
-                if (!AskYesOrNo("Quit Ocaml?"))
-                        return 0;
-                break;
-                // End application
-        case WM_DESTROY:
-                PostQuitMessage(0);
-                break;
-                // The interpreter has exited. Force close of the application
-        case WM_QUITOCAML:
-                DestroyWindow(hwnd);
-                return 0;
-        case WM_USER+1000:
-                // TestGraphics();
-                break;
-        default:
-                return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam);
-        }
-        return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam);
+	switch (msg) {
+		// Create the MDI client invisible window
+		case WM_CREATE:
+			hwndMDIClient = CreateMdiClient(hwnd);
+			TimerId = SetTimer((HWND) 0, 0, 100, (TIMERPROC) TimerProc);
+			break;
+			// Move the child windows
+		case WM_SIZE:
+			SendMessage(hWndStatusbar,msg,wParam,lParam);
+			InitializeStatusBar(hWndStatusbar,1);
+			// Position the MDI client window between the tool and status bars
+			if (wParam != SIZE_MINIMIZED) {
+				RECT rc, rcClient;
+
+				GetClientRect(hwnd, &rcClient);
+				GetWindowRect(hWndStatusbar, &rc);
+				ScreenToClient(hwnd, (LPPOINT)&rc.left);
+				rcClient.bottom = rc.top;
+				MoveWindow(hwndMDIClient,rcClient.left,rcClient.top,rcClient.right-rcClient.left, rcClient.bottom-rcClient.top, TRUE);
+			}
+
+			return 0;
+			// Dispatch the menu commands
+		case WM_COMMAND:
+			HandleCommand(hwnd, wParam,lParam);
+			return 0;
+			// If user confirms close
+		case WM_CLOSE:
+			if (!AskYesOrNo("Quit OCamlWinPlus?"))
+				return 0;
+			break;
+			// End application
+		case WM_DESTROY:
+			PostQuitMessage(0);
+			break;
+			// The interpreter has exited. Force close of the application
+		case WM_QUITOCAML:
+			DestroyWindow(hwnd);
+			return 0;
+		case WM_USER+1000:
+			// TestGraphics();
+			break;
+		default:
+			return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam);
+	}
+	return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam);
 }
 
 /*------------------------------------------------------------------------
- Procedure:     CreationCourier ID:1
- Purpose:       Creates the courier font
- Input:
- Output:
- Errors:
+Procedure:     CreationCourier ID:1
+Purpose:       Creates the courier font
+Input:
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 static HFONT CreationCourier(int flag)
 {
-   LOGFONT CurrentFont;
-   memset(&CurrentFont, 0, sizeof(LOGFONT));
-   CurrentFont.lfCharSet = ANSI_CHARSET;
-   CurrentFont.lfWeight = FW_NORMAL;
-   if (flag)
-      CurrentFont.lfHeight = 18;
-   else
-      CurrentFont.lfHeight = 15;
-   CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN);
-   strcpy(CurrentFont.lfFaceName, "Courier");  /* Courier */
-   return (CreateFontIndirect(&CurrentFont));
+	LOGFONT CurrentFont;
+	memset(&CurrentFont, 0, sizeof(LOGFONT));
+	CurrentFont.lfCharSet = ANSI_CHARSET;
+	CurrentFont.lfWeight = FW_NORMAL;
+	if (flag)
+		CurrentFont.lfHeight = 18;
+	else
+		CurrentFont.lfHeight = 15;
+	CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN);
+	strcpy(CurrentFont.lfFaceName, "Courier");  /* Courier */
+	return (CreateFontIndirect(&CurrentFont));
 }
 
 /*------------------------------------------------------------------------
- Procedure:     ReadToLineBuffer ID:1
- Purpose:       Reads into the line buffer the characters written by
-                the interpreter
- Input:         None
- Output:        The number of characters read
- Errors:        None
+Procedure:     ReadToLineBuffer ID:1
+Purpose:       Reads into the line buffer the characters written by
+the interpreter
+Input:         None
+Output:        The number of characters read
+Errors:        None
 ------------------------------------------------------------------------*/
 int ReadToLineBuffer(void)
 {
-        memset(lineBuffer,0,sizeof(lineBuffer));
-        return ReadFromPipe(lineBuffer,sizeof(lineBuffer));
+	memset(lineBuffer,0,sizeof(lineBuffer));
+	return ReadFromPipe(lineBuffer,sizeof(lineBuffer));
 }
 
 /*------------------------------------------------------------------------
- Procedure:     AddLineBuffer ID:1
- Purpose:       Sends the contents of the line buffer to the edit
-                control
- Input:         None
- Output:
- Errors:
+Procedure:     AddLineBuffer ID:1
+Purpose:       Sends the contents of the line buffer to the edit
+control
+Input:         None
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 int AddLineBuffer(void)
 {
-        HWND hEditCtrl;
+	HWND hEditCtrl;
 
-        hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER);
-        return SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)lineBuffer);
+	hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER);
+	return SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)lineBuffer);
 
 }
 
 /*------------------------------------------------------------------------
- Procedure:     Setup ID:1
- Purpose:       Handles GUI initialization (Fonts, brushes, colors,
-                etc)
- Input:
- Output:
- Errors:
+Procedure:     Setup ID:1
+Purpose:       Handles GUI initialization (Fonts, brushes, colors,
+etc)
+Input:
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 static int Setup(HANDLE *phAccelTable)
 {
-        if (!InitApplication())
-                return 0;
-        ProgramParams.hFont = CreationCourier(1);
-        ProgramParams.TextColor = RGB(0,0,0);
-        GetObject(ProgramParams.hFont,sizeof(LOGFONT),&CurrentFont);
-        BackgroundBrush = CreateSolidBrush(BackColor);
-        *phAccelTable = LoadAccelerators(hInst,MAKEINTRESOURCE(IDACCEL));
-        return 1;
+	if (!InitApplication())
+		return 0;
+	ProgramParams.hFont = CreationCourier(1);
+	ProgramParams.TextColor = RGB(0,0,0);
+	GetObject(ProgramParams.hFont,sizeof(LOGFONT),&CurrentFont);
+	BackgroundBrush = CreateSolidBrush(BackColor);
+	*phAccelTable = LoadAccelerators(hInst,MAKEINTRESOURCE(IDACCEL));
+	return 1;
 }
 
 
 /*------------------------------------------------------------------------
- Procedure:     WinMain ID:1
- Purpose:       Entry point for windows programs.
- Input:
- Output:
- Errors:
+Procedure:     WinMain ID:1
+Purpose:       Entry point for windows programs.
+Input:
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, INT nCmdShow)
 {
-        MSG msg;
-        HANDLE hAccelTable;
-        char consoleTitle[512];
-        HWND hwndConsole;
-
-        // Setup the hInst global
-        hInst = hInstance;
-        // Do the setup
-        if (!Setup(&hAccelTable))
-                return 0;
-        // Need to set up a console so that we can send ctrl-break signal
-        // to inferior Caml
-        AllocConsole();
-        GetConsoleTitle(consoleTitle,sizeof(consoleTitle));
-        hwndConsole = FindWindow(NULL,consoleTitle);
-        ShowWindow(hwndConsole,SW_HIDE);
-        // Create main window and exit if this fails
-        if ((hwndMain = CreateinriaWndClassWnd()) == (HWND)0)
-                return 0;
-        // Create the status bar
-        CreateSBar(hwndMain,"Ready",2);
-        // Show the window
-        ShowWindow(hwndMain,SW_SHOW);
-        // Create the session window
-        hwndSession = MDICmdFileNew("Session transcript",0);
-        // Get the path to ocaml.exe
-        GetOcamlPath();
-        // Start the interpreter
-        StartOcaml();
-        // Show the session window
-        ShowWindow(hwndSession, SW_SHOW);
-        // Maximize it
-    SendMessage(hwndMDIClient, WM_MDIMAXIMIZE, (WPARAM) hwndSession, 0);
-
-        PostMessage(hwndMain,WM_USER+1000,0,0);
-        while (GetMessage(&msg,NULL,0,0)) {
-                if (!TranslateMDISysAccel(hwndMDIClient, &msg))
-                        if (!TranslateAccelerator(msg.hwnd, hAccelTable, &msg)) {
-                                TranslateMessage(&msg);  // Translates virtual key codes
-                                DispatchMessage(&msg);   // Dispatches message to window
-                        }
-        }
-        WriteToPipe("#quit;;\r\n\032");
-    KillTimer((HWND) 0, TimerId);
-        return msg.wParam;
+	MSG msg;
+	HANDLE hAccelTable;
+	char consoleTitle[512];
+	HWND hwndConsole;
+
+	CurrentEditBuffer = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
+	CurrentEditBuffer->LineCount = 0;
+	CurrentEditBuffer->Lines = NULL;
+
+	//setup the history index pointer
+	historyEntry = NULL;
+
+	// Setup the hInst global
+	hInst = hInstance;
+	// Do the setup
+	if (!Setup(&hAccelTable))
+		return 0;
+	// Need to set up a console so that we can send ctrl-break signal
+	// to inferior Caml
+	AllocConsole();
+	GetConsoleTitle(consoleTitle,sizeof(consoleTitle));
+	hwndConsole = FindWindow(NULL,consoleTitle);
+	ShowWindow(hwndConsole,SW_HIDE);
+	// Create main window and exit if this fails
+	if ((hwndMain = CreateinriaWndClassWnd()) == (HWND)0)
+		return 0;
+	// Create the status bar
+	CreateSBar(hwndMain,"Ready",2);
+	// Show the window
+	ShowWindow(hwndMain,SW_SHOW);
+	// Create the session window
+	hwndSession = MDICmdFileNew("Session transcript",0);
+	// Get the path to ocaml.exe
+	GetOcamlPath();
+	// Start the interpreter
+	StartOcaml();
+	// Show the session window
+	ShowWindow(hwndSession, SW_SHOW);
+	// Maximize it
+	SendMessage(hwndMDIClient, WM_MDIMAXIMIZE, (WPARAM) hwndSession, 0);
+
+	PostMessage(hwndMain,WM_USER+1000,0,0);
+	while (GetMessage(&msg,NULL,0,0)) {
+		if (!TranslateMDISysAccel(hwndMDIClient, &msg))
+			if (!TranslateAccelerator(msg.hwnd, hAccelTable, &msg)) {
+				TranslateMessage(&msg);  // Translates virtual key codes
+				DispatchMessage(&msg);   // Dispatches message to window
+			}
+	}
+	WriteToPipe("#quit;;\r\n\032");
+	KillTimer((HWND) 0, TimerId);
+	return msg.wParam;
 }
diff --git a/win32caml/ocaml.rc b/win32caml/ocaml.rc
index 8c777f27..c10ecdba 100644
--- a/win32caml/ocaml.rc
+++ b/win32caml/ocaml.rc
@@ -1,114 +1,255 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  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: ocaml.rc,v 1.3 2001/12/07 13:41:02 xleroy Exp $ */
-
-/* Wedit generated resource file */
-#include <windows.h>
-#include "inriares.h"
-
-1000 ICON "ocaml.ico"
-IDMAINMENU MENU
-BEGIN
-    POPUP "&File"
-        BEGIN
-        MENUITEM "&Open...", IDM_OPEN
-        MENUITEM "&Save", IDM_SAVE
-        MENUITEM "Save &As...", IDM_SAVEAS
-        MENUITEM "&Close", IDM_CLOSE
-        MENUITEM SEPARATOR
-        MENUITEM "&Print", IDM_PRINT
-        MENUITEM "P&rint Setup...", IDM_PRINTSU
-        MENUITEM SEPARATOR
-        MENUITEM "E&xit", IDM_EXIT
-        END
-    POPUP "&Edit"
-        BEGIN
-        MENUITEM "&Undo Alt+BkSp", IDM_EDITUNDO
-        MENUITEM SEPARATOR
-        MENUITEM "Cu&t  Shift+Del", IDM_EDITCUT
-        MENUITEM "&Copy Ctrl+Ins", IDM_EDITCOPY
-        MENUITEM "&Paste        Shift+Ins", IDM_EDITPASTE
-        MENUITEM "&Delete       Del", IDM_EDITCLEAR
-        END
-    POPUP "Workspace"
-        BEGIN
-        MENUITEM "Font", IDM_FONT
-        MENUITEM "Text Color", IDM_COLORTEXT
-        MENUITEM "Background color", IDM_BACKCOLOR
-        MENUITEM SEPARATOR
-        MENUITEM "&History", IDM_HISTORY
-        MENUITEM "&Garbage collect", IDM_GC
-        MENUITEM "&Interrupt", IDCTRLC
-        END
-    POPUP "&Window"
-        BEGIN
-        MENUITEM "&Tile", IDM_WINDOWTILE
-        MENUITEM "&Cascade", IDM_WINDOWCASCADE
-        MENUITEM "Arrange &Icons", IDM_WINDOWICONS
-        MENUITEM "Close &All", IDM_WINDOWCLOSEALL
-        END
-    POPUP "&Help"
-        BEGIN
-        MENUITEM "&About...", IDM_ABOUT
-        END
-END
-BARMDI ACCELERATORS
-BEGIN
-    81, IDM_EXIT, VIRTKEY, CONTROL 
-END
-
-IDD_ABOUT DIALOGEX 7, 29, 236, 81
-STYLE DS_CENTER | WS_POPUP | WS_VISIBLE | WS_CAPTION | WS_SYSMENU
-EXSTYLE WS_EX_CLIENTEDGE | WS_EX_TOOLWINDOW
-CAPTION "About Ocaml"
-FONT 8, "MS Sans Serif"
-BEGIN
-    LTEXT           "The Objective Caml system for windows", 101, 56, 9, 126, 12
-    LTEXT           "Windows Interface 2.0", 102, 78, 21, 72, 12
-    LTEXT           "Copyright 1996-2001", 103, 84, 42, 66, 10
-    CTEXT           "Institut National de Recherche en Informatique et Automatique", 104, 15, 56, 211, 10
-    CTEXT           "Réalisé par Jacob Navia 2001", 105, 19, 66, 207, 12
-END
-
-IDD_HISTORY DIALOGEX 6, 18, 261, 184
-STYLE DS_MODALFRAME | WS_POPUP | WS_VISIBLE | WS_CAPTION | WS_SYSMENU | WS_THICKFRAME
-EXSTYLE WS_EX_TOOLWINDOW
-CAPTION "Session History"
-FONT 8, "MS Sans Serif"
-BEGIN
-    LISTBOX         IDLIST, 7, 7, 247, 173, LBS_USETABSTOPS | WS_VSCROLL | WS_HSCROLL | WS_TABSTOP
-END
-STRINGTABLE
-BEGIN
-    3010, "Switches to "
-    2010, "Get help"
-    2000, "Create, open, save, or print documents"
-    500, "Displays information about this application"
-    440, "Closes all open windows"
-    430, "Arranges minimized window icons"
-    420, "Arranges windows as overlapping tiles"
-    410, "Arranges windows as non-overlapping tiles"
-    350, "Removes the selection without putting it on the clipboard"
-    340, "Inserts the clipboard contents at the insertion point"
-    330, "Copies the selection and puts it on the clipboard"
-    320, "Cuts the selection and puts it on the clipboard"
-    310, "Reverses the last action"
-    270, "Quits this application"
-    260, "Changes the printer selection or configuration"
-    250, "Prints the active document"
-    240, "Closes the active document"
-    230, "Saves the active document under a different name"
-    220, "Saves the active document"
-    210, "Opens an existing document"
-    200, "Creates a new session"
-END
+// Microsoft Visual C++ generated resource script.
+//
+#include "resource.h"
+
+#define APSTUDIO_READONLY_SYMBOLS
+/////////////////////////////////////////////////////////////////////////////
+//
+// Generated from the TEXTINCLUDE 2 resource.
+//
+#define APSTUDIO_HIDDEN_SYMBOLS
+#include "windows.h"
+#undef APSTUDIO_HIDDEN_SYMBOLS
+#include "inriares.h"
+
+/////////////////////////////////////////////////////////////////////////////
+#undef APSTUDIO_READONLY_SYMBOLS
+
+/////////////////////////////////////////////////////////////////////////////
+// English (U.S.) resources
+
+#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU)
+#ifdef _WIN32
+LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US
+#pragma code_page(1252)
+#endif //_WIN32
+
+/////////////////////////////////////////////////////////////////////////////
+//
+// Icon
+//
+
+// Icon with lowest ID value placed first to ensure application icon
+// remains consistent on all systems.
+1000                    ICON                    "ocaml.ico"
+
+/////////////////////////////////////////////////////////////////////////////
+//
+// Menu
+//
+
+IDMAINMENU MENU 
+BEGIN
+    POPUP "&File"
+    BEGIN
+        MENUITEM "&Open...",                    IDM_OPEN
+        MENUITEM "&Save ML...",                 IDM_SAVE
+        MENUITEM "Save &Transcript...",         IDM_SAVEAS
+        MENUITEM SEPARATOR
+        MENUITEM "&Print",                      IDM_PRINT, GRAYED
+        MENUITEM "P&rint Setup...",             IDM_PRINTSU, GRAYED
+        MENUITEM SEPARATOR
+        MENUITEM "E&xit",                       IDM_EXIT
+    END
+    POPUP "&Edit"
+    BEGIN
+        MENUITEM "&Undo\tAlt+BkSp",             IDM_EDITUNDO
+        MENUITEM SEPARATOR
+        MENUITEM "Cu&t\t Shift+Del",            IDM_EDITCUT
+        MENUITEM "&Copy\tCtrl+Ins",             IDM_EDITCOPY
+        MENUITEM "&Paste\tShift+Ins",           IDM_EDITPASTE
+    END
+    POPUP "Workspace"
+    BEGIN
+        MENUITEM "&Font...",                    IDM_FONT
+        MENUITEM "Text &Color...",              IDM_COLORTEXT
+        MENUITEM "&Background Color...",        IDM_BACKCOLOR
+        MENUITEM SEPARATOR
+        MENUITEM "&History...",                 IDM_HISTORY
+        MENUITEM "&Garbage Collect",            IDM_GC
+        MENUITEM "&Interrupt",                  IDCTRLC
+    END
+    POPUP "&Window", GRAYED
+    BEGIN
+        MENUITEM "&Tile",                       IDM_WINDOWTILE, INACTIVE
+        MENUITEM "&Cascade",                    IDM_WINDOWCASCADE, INACTIVE
+        MENUITEM "Arrange &Icons",              IDM_WINDOWICONS, INACTIVE
+        MENUITEM "Close &All",                  IDM_WINDOWCLOSEALL, INACTIVE
+    END
+    POPUP "&Help"
+    BEGIN
+        MENUITEM "&About...",                   IDM_ABOUT
+    END
+END
+
+
+/////////////////////////////////////////////////////////////////////////////
+//
+// Accelerator
+//
+
+BARMDI ACCELERATORS 
+BEGIN
+    "Q",            IDM_EXIT,               VIRTKEY, CONTROL
+END
+
+
+/////////////////////////////////////////////////////////////////////////////
+//
+// Dialog
+//
+
+IDD_ABOUT DIALOGEX 7, 29, 236, 81
+STYLE DS_SETFONT | DS_CENTER | WS_POPUP | WS_VISIBLE | WS_CAPTION | 
+    WS_SYSMENU
+EXSTYLE WS_EX_TOOLWINDOW | WS_EX_CLIENTEDGE
+CAPTION "About OCamlWinPlus"
+FONT 8, "MS Sans Serif", 0, 0, 0x1
+BEGIN
+    LTEXT           "Objective Caml for Windows",101,75,7,90,12
+    LTEXT           "New Windows Interface 1.9RC4",102,68,15,104,12
+    CTEXT           "Copyright 1996-2001\nUpdated 2003",103,88,25,66,23
+    CTEXT           "Institut National de Recherche en Informatique et Automatique",
+                    104,16,46,211,10
+    CTEXT           "Réalisé par Jacob Navia 2001.  Updated by Chris Watford 2003.\nwatford@uiuc.edu",
+                    105,18,54,207,19
+END
+
+IDD_HISTORY DIALOGEX 6, 18, 261, 184
+STYLE DS_SETFONT | DS_MODALFRAME | WS_POPUP | WS_VISIBLE | WS_CAPTION | 
+    WS_SYSMENU | WS_THICKFRAME
+EXSTYLE WS_EX_TOOLWINDOW
+CAPTION "Session History"
+FONT 8, "MS Sans Serif", 0, 0, 0x1
+BEGIN
+    LISTBOX         IDLIST,7,7,247,173,LBS_USETABSTOPS | WS_VSCROLL | 
+                    WS_HSCROLL | WS_TABSTOP
+END
+
+
+#ifdef APSTUDIO_INVOKED
+/////////////////////////////////////////////////////////////////////////////
+//
+// TEXTINCLUDE
+//
+
+1 TEXTINCLUDE 
+BEGIN
+    "resource.h\0"
+END
+
+2 TEXTINCLUDE 
+BEGIN
+    "#define APSTUDIO_HIDDEN_SYMBOLS\r\n"
+    "#include ""windows.h""\r\n"
+    "#undef APSTUDIO_HIDDEN_SYMBOLS\r\n"
+    "#include ""inriares.h""\r\n"
+    "\0"
+END
+
+3 TEXTINCLUDE 
+BEGIN
+    "\r\n"
+    "\0"
+END
+
+#endif    // APSTUDIO_INVOKED
+
+
+/////////////////////////////////////////////////////////////////////////////
+//
+// String Table
+//
+
+STRINGTABLE 
+BEGIN
+    3010                    "Switches to "
+END
+
+STRINGTABLE 
+BEGIN
+    2000                    "Create, open, save, or print documents"
+    2010                    "Get help"
+END
+
+STRINGTABLE 
+BEGIN
+    500                     "Displays information about this application"
+END
+
+STRINGTABLE 
+BEGIN
+    440                     "Closes all open windows"
+END
+
+STRINGTABLE 
+BEGIN
+    420                     "Arranges windows as overlapping tiles"
+    430                     "Arranges minimized window icons"
+END
+
+STRINGTABLE 
+BEGIN
+    410                     "Arranges windows as non-overlapping tiles"
+END
+
+STRINGTABLE 
+BEGIN
+    340                     "Inserts the clipboard contents at the insertion point"
+    350                     "Removes the selection without putting it on the clipboard"
+END
+
+STRINGTABLE 
+BEGIN
+    320                     "Cuts the selection and puts it on the clipboard"
+    330                     "Copies the selection and puts it on the clipboard"
+END
+
+STRINGTABLE 
+BEGIN
+    310                     "Reverses the last action"
+END
+
+STRINGTABLE 
+BEGIN
+    260                     "Changes the printer selection or configuration"
+    270                     "Quits this application"
+END
+
+STRINGTABLE 
+BEGIN
+    240                     "Closes the active document"
+    250                     "Prints the active document"
+END
+
+STRINGTABLE 
+BEGIN
+    230                     "Saves the active document under a different name"
+END
+
+STRINGTABLE 
+BEGIN
+    210                     "Opens an existing document"
+    220                     "Saves the active document"
+END
+
+STRINGTABLE 
+BEGIN
+    200                     "Creates a new session"
+END
+
+#endif    // English (U.S.) resources
+/////////////////////////////////////////////////////////////////////////////
+
+
+
+#ifndef APSTUDIO_INVOKED
+/////////////////////////////////////////////////////////////////////////////
+//
+// Generated from the TEXTINCLUDE 3 resource.
+//
+
+
+/////////////////////////////////////////////////////////////////////////////
+#endif    // not APSTUDIO_INVOKED
+
diff --git a/win32caml/resource.h b/win32caml/resource.h
new file mode 100644
index 00000000..27bf5ea1
--- /dev/null
+++ b/win32caml/resource.h
@@ -0,0 +1,16 @@
+//{{NO_DEPENDENCIES}}
+// Microsoft Visual C++ generated include file.
+// Used by ocaml.rc
+//
+
+// Next default values for new objects
+// 
+#ifdef APSTUDIO_INVOKED
+#ifndef APSTUDIO_READONLY_SYMBOLS
+#define _APS_NO_MFC                     1
+#define _APS_NEXT_RESOURCE_VALUE        101
+#define _APS_NEXT_COMMAND_VALUE         40001
+#define _APS_NEXT_CONTROL_VALUE         1000
+#define _APS_NEXT_SYMED_VALUE           101
+#endif
+#endif
diff --git a/win32caml/startocaml.c b/win32caml/startocaml.c
index 25656f83..06d7a90f 100644
--- a/win32caml/startocaml.c
+++ b/win32caml/startocaml.c
@@ -10,49 +10,55 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: startocaml.c,v 1.8 2003/09/09 09:07:14 xleroy Exp $ */
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+/* $Id: startocaml.c,v 1.9.2.1 2004/07/06 15:16:04 xleroy Exp $ */
 
 #include <windows.h>
 #include <stdio.h>
-#include <direct.h>
 #include <io.h>
+#include <direct.h>
 #include "inria.h"
+
 PROCESS_INFORMATION pi;
 #define BUFSIZE 4096
 STARTUPINFO startInfo;
 
 /*------------------------------------------------------------------------
- Procedure:     ShowDbgMsg ID:1
- Purpose:       Puts up a dialog box with a message, forcing it to
-                the foreground.
- Input:
- Output:
- Errors:
+Procedure:     ShowDbgMsg ID:1
+Purpose:       Puts up a dialog box with a message, forcing it to
+the foreground.
+Input:
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 void ShowDbgMsg(char *str)
 {
-        HWND hWnd;
-        char p[20], message[255];
-        hWnd = hwndMain;
-        if (IsIconic(hWnd)){
-                ShowWindow(hWnd,SW_RESTORE);
-        }
-        strncpy(message, str, 254);
-        message[254] = 0;
-        strcpy(p, "Error");
-        MessageBox(hWnd, message, p, MB_OK | MB_ICONHAND|MB_TASKMODAL|MB_SETFOREGROUND);
+	HWND hWnd;
+	char p[20], message[255];
+	hWnd = hwndMain;
+	if (IsIconic(hWnd)){
+		ShowWindow(hWnd,SW_RESTORE);
+	}
+	strncpy(message, str, 254);
+	message[254] = 0;
+	strcpy(p, "Error");
+	MessageBox(hWnd, message, p, MB_OK | MB_ICONHAND|MB_TASKMODAL|MB_SETFOREGROUND);
 }
 
 int AskYesOrNo(char *msg)
 {
-        HWND hwnd;
-        int r;
-
-        hwnd = hwndMain;
-        r = MessageBox(hwnd, msg, "Ocaml", MB_YESNO | MB_SETFOREGROUND);
-        if (r == IDYES)
-                return (TRUE);
-        return (FALSE);
+	HWND hwnd;
+	int r;
+
+	hwnd = hwndMain;
+	r = MessageBox(hwnd, msg, "Ocaml", MB_YESNO | MB_SETFOREGROUND);
+	if (r == IDYES)
+		return (TRUE);
+	return (FALSE);
 }
 
 
@@ -60,305 +66,307 @@ static DWORD OcamlStatus;
 
 static int RegistryError(void)
 {
-        char buf[512];
+	char buf[512];
 
-        wsprintf(buf,"Error %d writing to the registry",GetLastError());
-        ShowDbgMsg(buf);
-        return 0;
+	wsprintf(buf,"Error %d writing to the registry",GetLastError());
+	ShowDbgMsg(buf);
+	return 0;
 }
 
 static int ReadRegistry(HKEY hroot,
-                        char * p1, char * p2, char * p3,
-                        char dest[1024])
+						char * p1, char * p2, char * p3,
+						char dest[1024])
 {
-  HKEY h1, h2;
-  DWORD dwType;
-  unsigned long size;
-  LONG ret;
-
-  if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
-    return 0;
-  if (RegOpenKeyExA(h1, p2, 0, KEY_QUERY_VALUE, &h2) != ERROR_SUCCESS) {
-    RegCloseKey(h1);
-    return 0;
-  }
-  dwType = REG_SZ;
-  size = 1024;
-  ret = RegQueryValueExA(h2, p3, 0, &dwType, dest, &size);
-  RegCloseKey(h2);
-  RegCloseKey(h1);
-  return ret == ERROR_SUCCESS;
+	HKEY h1, h2;
+	DWORD dwType;
+	unsigned long size;
+	LONG ret;
+
+	if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
+		return 0;
+	if (RegOpenKeyExA(h1, p2, 0, KEY_QUERY_VALUE, &h2) != ERROR_SUCCESS) {
+		RegCloseKey(h1);
+		return 0;
+	}
+	dwType = REG_SZ;
+	size = 1024;
+	ret = RegQueryValueExA(h2, p3, 0, &dwType, dest, &size);
+	RegCloseKey(h2);
+	RegCloseKey(h1);
+	return ret == ERROR_SUCCESS;
 }
 
 static int WriteRegistry(HKEY hroot,
-                          char * p1, char * p2, char * p3,
-                          char data[1024])
+						 char * p1, char * p2, char * p3,
+						 char data[1024])
 {
-  HKEY h1, h2;
-  DWORD disp;
-  LONG ret;
-
-  if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
-    return 0;
-  if (RegCreateKeyExA(h1, p2, 0, NULL, 0, KEY_ALL_ACCESS, NULL, &h2, &disp)
-      != ERROR_SUCCESS) {
-    RegCloseKey(h1);
-    return 0;
-  }
-  ret = RegSetValueEx(h2, p3, 0, REG_SZ, data, strlen(data) + 1);
-  RegCloseKey(h2);
-  RegCloseKey(h1);
-  return ret == ERROR_SUCCESS;
+	HKEY h1, h2;
+	DWORD disp;
+	LONG ret;
+
+	if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
+		return 0;
+	if (RegCreateKeyExA(h1, p2, 0, NULL, 0, KEY_ALL_ACCESS, NULL, &h2, &disp)
+		!= ERROR_SUCCESS) {
+			RegCloseKey(h1);
+			return 0;
+		}
+		ret = RegSetValueEx(h2, p3, 0, REG_SZ, data, strlen(data) + 1);
+		RegCloseKey(h2);
+		RegCloseKey(h1);
+		return ret == ERROR_SUCCESS;
 }
 
 /*------------------------------------------------------------------------
- Procedure:     GetOcamlPath ID:1
- Purpose:       Read the registry key 
-                HKEY_LOCAL_MACHINE\Software\Objective Caml
-                or
-                HKEY_CURRENT_USER\Software\Objective Caml,
-                and creates it if it doesn't exists.
-                If any error occurs, i.e. the
-                given path doesn't exist, or the key didn't exist, it
-                will put up a browse dialog box to allow the user to
-                enter the path. The path will be verified that it
-                points to a file that exists. If that file is in a
-                directory called 'bin', it will look for another
-                directory in the same level called lib' and set the
-                Lib path to that.
- Input:         None explicit
- Output:        1 means sucess, zero failure
- Errors:        Almost all system calls will be verified
+Procedure:     GetOcamlPath ID:1
+Purpose:       Read the registry key 
+HKEY_LOCAL_MACHINE\Software\Objective Caml
+or
+HKEY_CURRENT_USER\Software\Objective Caml,
+and creates it if it doesn't exists.
+If any error occurs, i.e. the
+given path doesn't exist, or the key didn't exist, it
+will put up a browse dialog box to allow the user to
+enter the path. The path will be verified that it
+points to a file that exists. If that file is in a
+directory called 'bin', it will look for another
+directory in the same level called lib' and set the
+Lib path to that.
+Input:         None explicit
+Output:        1 means sucess, zero failure
+Errors:        Almost all system calls will be verified
 ------------------------------------------------------------------------*/
 int GetOcamlPath(void)
 {
-  char path[1024], *p;
-
- again:
-  if (! ReadRegistry(HKEY_CURRENT_USER,
-                     "Software", "Objective Caml",
-                     "InterpreterPath", path)
-      &&
-      ! ReadRegistry(HKEY_LOCAL_MACHINE,
-                     "Software", "Objective Caml",
-                     "InterpreterPath", path)) {
-    /* Key doesn't exist?  Ask user */
-    path[0] = '\0';
-    if (!BrowseForFile("Ocaml interpreter|ocaml.exe", path)) {
-      ShowDbgMsg("Impossible to find ocaml.exe. I quit");
-      exit(0);
-    }
-    WriteRegistry(HKEY_CURRENT_USER,
-                  "Software", "Objective Caml",
-                  "InterpreterPath", path);
-  }
-  /* Check if file exists */
-  if (_access(path, 0) != 0) {
-    char *errormsg = malloc(1024);
-    wsprintf(errormsg,"Incorrect path for ocaml.exe:\n%s", path);
-    ShowDbgMsg(errormsg);
-    free(errormsg);
-    path[0] = 0;
-    WriteRegistry(HKEY_CURRENT_USER,
-                  "Software", "Objective Caml",
-                  "InterpreterPath", path);
-    goto again;
-  }
-  strcpy(OcamlPath, path);
-  p = strrchr(OcamlPath,'\\');
-  if (p) {
-    *p = 0;
-    strcpy(LibDir,OcamlPath);
-    *p = '\\';
-    p = strrchr(LibDir,'\\');
-    if (p && !stricmp(p,"\\bin")) {
-      *p = 0;
-      strcat(LibDir,"\\lib");
-    }
-  }
-  return 1;
+	char path[1024], *p;
+
+again:
+	if (! ReadRegistry(HKEY_CURRENT_USER,
+		"Software", "Objective Caml",
+		"InterpreterPath", path)
+		&&
+		! ReadRegistry(HKEY_LOCAL_MACHINE,
+		"Software", "Objective Caml",
+		"InterpreterPath", path)) {
+			/* Key doesn't exist?  Ask user */
+			if (!BrowseForFile("Ocaml interpreter|ocaml.exe", path)) {
+				ShowDbgMsg("Impossible to find ocaml.exe. I quit");
+				exit(0);
+			}
+			WriteRegistry(HKEY_CURRENT_USER,
+				"Software", "Objective Caml",
+				"InterpreterPath", path);
+		}
+		/* Check if file exists */
+		if (_access(path, 0) != 0) {
+			char *errormsg = malloc(1024);
+			wsprintf(errormsg,"Incorrect path for ocaml.exe:\n%s", path);
+			ShowDbgMsg(errormsg);
+			free(errormsg);
+			path[0] = 0;
+			WriteRegistry(HKEY_CURRENT_USER,
+				"Software", "Objective Caml",
+				"InterpreterPath", path);
+			goto again;
+		}
+		strcpy(OcamlPath, path);
+		p = strrchr(OcamlPath,'\\');
+		if (p) {
+			*p = 0;
+			strcpy(LibDir,OcamlPath);
+			*p = '\\';
+			p = strrchr(LibDir,'\\');
+			if (p && !stricmp(p,"\\bin")) {
+				*p = 0;
+				strcat(LibDir,"\\lib");
+			}
+		}
+		return 1;
 }
 
 static HANDLE hChildStdinRd, hChildStdinWr,hChildStdoutRd, hChildStdoutWr;
 /*------------------------------------------------------------------------
- Procedure:     IsWindowsNT ID:1
- Purpose:       Returns 1 if we are running under windows NT, zero
-                otherwise.
- Input:         None
- Output:        1 or zero
- Errors:
+Procedure:     IsWindowsNT ID:1
+Purpose:       Returns 1 if we are running under windows NT, zero
+otherwise.
+Input:         None
+Output:        1 or zero
+Errors:
 ------------------------------------------------------------------------*/
 int IsWindowsNT(void)
 {
-        OSVERSIONINFO osv;
+	OSVERSIONINFO osv;
 
-        osv.dwOSVersionInfoSize = sizeof(osv);
-        GetVersionEx(&osv);
-        return(osv.dwPlatformId == VER_PLATFORM_WIN32_NT);
+	osv.dwOSVersionInfoSize = sizeof(osv);
+	GetVersionEx(&osv);
+	return(osv.dwPlatformId == VER_PLATFORM_WIN32_NT);
 }
 
 /*------------------------------------------------------------------------
- Procedure:     DoStartOcaml ID:1
- Purpose:       Starts the ocaml interpreter ocaml.exe. The standard
-                input of the interpreter will be connected to a pipe,
-                and the standard output and standard error to another
-                pipe. The interpreter starts as a hidden process,
-                showing only in the task list. Since this is in an
-                own thread, its workings are independent of the rest
-                of the program. After starting the interpreter, the
-                thread waits in case the interpreter exits, for
-                instance if the user or some program types #quit;;.
-                In this case, the waiting thread awakens and exits
-                the user interface.
- Input:         Not used. It uses the OcamlPath global variable, that
-                is supposed to be correct, no test for its validity
-                are done here.
- Output:        None visible
- Errors:        If any system call for whatever reason fails, the
-                thread will exit. No error message is shown.
+Procedure:     DoStartOcaml ID:1
+Purpose:       Starts the ocaml interpreter ocaml.exe. The standard
+input of the interpreter will be connected to a pipe,
+and the standard output and standard error to another
+pipe. The interpreter starts as a hidden process,
+showing only in the task list. Since this is in an
+own thread, its workings are independent of the rest
+of the program. After starting the interpreter, the
+thread waits in case the interpreter exits, for
+instance if the user or some program types #quit;;.
+In this case, the waiting thread awakens and exits
+the user interface.
+Input:         Not used. It uses the OcamlPath global variable, that
+is supposed to be correct, no test for its validity
+are done here.
+Output:        None visible
+Errors:        If any system call for whatever reason fails, the
+thread will exit. No error message is shown.
 ------------------------------------------------------------------------*/
-DWORD _stdcall DoStartOcaml(LPVOID param)
+DWORD WINAPI DoStartOcaml(LPVOID param)
 {
-        char *cmdline;
-        int processStarted;
-        LPSECURITY_ATTRIBUTES lpsa=NULL;
-        SECURITY_ATTRIBUTES sa;
-        SECURITY_DESCRIPTOR sd;
-	HWND hwndParent = (HWND) param;
-
-        sa.nLength = sizeof(SECURITY_ATTRIBUTES);
-        // Under windows NT/2000/Whistler we have to initialize the security descriptors
-        // This is not necessary under windows 98/95.
-        if (IsWindowsNT()) {
-                InitializeSecurityDescriptor(&sd,SECURITY_DESCRIPTOR_REVISION);
-                SetSecurityDescriptorDacl(&sd,TRUE,NULL,FALSE);
-                sa.bInheritHandle = TRUE;
-                sa.lpSecurityDescriptor = &sd;
-                lpsa = &sa;
-        }
-        memset(&startInfo,0,sizeof(STARTUPINFO));
-        startInfo.cb = sizeof(STARTUPINFO);
-        // Create a pipe for the child process's STDOUT.
-        if (! CreatePipe(&hChildStdoutRd, &hChildStdoutWr, &sa, 0))
-                return 0;
-        // Create a pipe for the child process's STDIN.
-        if (! CreatePipe(&hChildStdinRd, &hChildStdinWr, &sa, 0))
-                return 0;
-        // Setup the start info structure
-        startInfo.dwFlags = STARTF_USESTDHANDLES|STARTF_USESHOWWINDOW;
-        startInfo.wShowWindow = SW_HIDE;
-        startInfo.hStdOutput = hChildStdoutWr;
-        startInfo.hStdError = hChildStdoutWr;
-        startInfo.hStdInput = hChildStdinRd;
-        cmdline = OcamlPath;
-        // Set the OCAMLLIB environment variable
-        SetEnvironmentVariable("OCAMLLIB", LibDir);
-        // Let's go: start the ocaml interpreter
-        processStarted = CreateProcess(NULL,cmdline,lpsa,lpsa,1,
-                CREATE_NEW_PROCESS_GROUP|NORMAL_PRIORITY_CLASS,
-                NULL,ProgramParams.CurrentWorkingDir,&startInfo,&pi);
-        if (processStarted) {
-                WaitForSingleObject(pi.hProcess,INFINITE);
-                GetExitCodeProcess(pi.hProcess,(unsigned long *)&OcamlStatus);
-                CloseHandle(pi.hProcess);
-                PostMessage(hwndMain,WM_QUITOCAML,0,0);
-        }
-        else {
-                char *msg = malloc(1024);
-                wsprintf(msg,"Impossible to start ocaml.exe in:\n%s",cmdline);
-                ShowDbgMsg(msg);
-                free(msg);
-        }
-        return 0;
+        HWND hwndParent = (HWND) param;
+	char *cmdline;
+	int processStarted;
+	LPSECURITY_ATTRIBUTES lpsa=NULL;
+	SECURITY_ATTRIBUTES sa;
+	SECURITY_DESCRIPTOR sd;
+
+	sa.nLength = sizeof(SECURITY_ATTRIBUTES);
+	// Under windows NT/2000/Whistler we have to initialize the security descriptors
+	// This is not necessary under windows 98/95.
+	if (IsWindowsNT()) {
+		InitializeSecurityDescriptor(&sd,SECURITY_DESCRIPTOR_REVISION);
+		SetSecurityDescriptorDacl(&sd,TRUE,NULL,FALSE);
+		sa.bInheritHandle = TRUE;
+		sa.lpSecurityDescriptor = &sd;
+		lpsa = &sa;
+	}
+	memset(&startInfo,0,sizeof(STARTUPINFO));
+	startInfo.cb = sizeof(STARTUPINFO);
+	// Create a pipe for the child process's STDOUT.
+	if (! CreatePipe(&hChildStdoutRd, &hChildStdoutWr, &sa, 0))
+		return 0;
+	// Create a pipe for the child process's STDIN.
+	if (! CreatePipe(&hChildStdinRd, &hChildStdinWr, &sa, 0))
+		return 0;
+	// Setup the start info structure
+	startInfo.dwFlags = STARTF_USESTDHANDLES|STARTF_USESHOWWINDOW;
+	startInfo.wShowWindow = SW_HIDE;
+	startInfo.hStdOutput = hChildStdoutWr;
+	startInfo.hStdError = hChildStdoutWr;
+	startInfo.hStdInput = hChildStdinRd;
+	cmdline = OcamlPath;
+	// Set the OCAMLLIB environment variable
+	SetEnvironmentVariable("OCAMLLIB", LibDir);
+	// Let's go: start the ocaml interpreter
+	processStarted = CreateProcess(NULL,cmdline,lpsa,lpsa,1,
+		CREATE_NEW_PROCESS_GROUP|NORMAL_PRIORITY_CLASS,
+		NULL,ProgramParams.CurrentWorkingDir,&startInfo,&pi);
+	if (processStarted) {
+		WaitForSingleObject(pi.hProcess,INFINITE);
+		GetExitCodeProcess(pi.hProcess,(unsigned long *)&OcamlStatus);
+		CloseHandle(pi.hProcess);
+		PostMessage(hwndMain,WM_QUITOCAML,0,0);
+	}
+	else {
+		char *msg = malloc(1024);
+		wsprintf(msg,"Impossible to start ocaml.exe in:\n%s",cmdline);
+		ShowDbgMsg(msg);
+		free(msg);
+	}
+	return 0;
 }
 
 /*------------------------------------------------------------------------
- Procedure:     WriteToPipe ID:1
- Purpose:       Writes the given character string to the standard
-                input of the interpreter
- Input:         The character string (zero terminated) to be written
- Output:        The number of characters written or zero if an error
-                occurs
- Errors:        None
+Procedure:     WriteToPipe ID:1
+Purpose:       Writes the given character string to the standard
+input of the interpreter
+Input:         The character string (zero terminated) to be written
+Output:        The number of characters written or zero if an error
+occurs
+Errors:        None
 ------------------------------------------------------------------------*/
 int WriteToPipe(char *data)
 {
-        DWORD dwWritten;
-        if (! WriteFile(hChildStdinWr, data, strlen(data),
-                &dwWritten, NULL))
-                return 0;
-        return dwWritten;
+	DWORD dwWritten;
+
+	if (! WriteFile(hChildStdinWr, data, strlen(data), &dwWritten, NULL))
+		return 0;
+
+	return dwWritten;
 
 }
 
 /*------------------------------------------------------------------------
- Procedure:     ReadFromPipe ID:1
- Purpose:       Reads from the standard output of the interpreter and
-                stores the data in the given buffer up to the given
-                length. This is done in a non-blocking manner, i.e.
-                it is safe to call this even if there is no data
-                available.
- Input:         The buffer to be used and its length.
- Output:        Returns the number of characters read from the pipe.
- Errors:        None explicit
+Procedure:     ReadFromPipe ID:1
+Purpose:       Reads from the standard output of the interpreter and
+stores the data in the given buffer up to the given
+length. This is done in a non-blocking manner, i.e.
+it is safe to call this even if there is no data
+available.
+Input:         The buffer to be used and its length.
+Output:        Returns the number of characters read from the pipe.
+Errors:        None explicit
 ------------------------------------------------------------------------*/
 int ReadFromPipe(char *data,int len)
 {
-        DWORD dwRead;
+	DWORD dwRead;
+
+	PeekNamedPipe(hChildStdoutRd,data,len,NULL,&dwRead,NULL);
+	if (dwRead == 0)
+		return 0;
 
-        PeekNamedPipe(hChildStdoutRd,data,len,NULL,&dwRead,NULL);
-        if (dwRead == 0)
-                return 0;
+	// Read output from the child process, and write to parent's STDOUT.
+	if( !ReadFile( hChildStdoutRd, data, len, &dwRead, NULL) || dwRead == 0)
+		return 0;
 
-        // Read output from the child process, and write to parent's STDOUT.
-        if( !ReadFile( hChildStdoutRd, data, len, &dwRead,
-                NULL) || dwRead == 0)
-                return 0;
-        return dwRead;
+	return dwRead;
 }
 
 static DWORD tid;
 /*------------------------------------------------------------------------
- Procedure:     StartOcaml ID:1
- Purpose:       Starts the thread that will call the ocaml.exe
-                program.
- Input:
- Output:
- Errors:
+Procedure:     StartOcaml ID:1
+Purpose:       Starts the thread that will call the ocaml.exe
+program.
+Input:
+Output:
+Errors:
 ------------------------------------------------------------------------*/
 int StartOcaml(void)
 {
-        getcwd(ProgramParams.CurrentWorkingDir,sizeof(ProgramParams.CurrentWorkingDir));
-        CreateThread(NULL,0,DoStartOcaml,hwndMain,0,&tid);
-        return 1;
+	getcwd(ProgramParams.CurrentWorkingDir,sizeof(ProgramParams.CurrentWorkingDir));
+	CreateThread(NULL,0,DoStartOcaml,hwndMain,0,&tid);
+	return 1;
 }
 
 
 void *SafeMalloc(int size)
 {
-        void *result;
+	void *result;
 
-        if (size < 0) {
-                char message[1024];
+	if (size < 0) {
+		char message[1024];
 
 error:
-                sprintf(message,"Can't allocate %d bytes",size);
-                MessageBox(NULL,message,"Ocaml",MB_OK);
-                exit(-1);
-        }
-        result = malloc(size);
-        if (result == NULL)
-                goto error;
-        return result;
+		sprintf(message,"Can't allocate %d bytes",size);
+		MessageBox(NULL, message, "Ocaml", MB_OK);
+		exit(-1);
+	}
+	result = malloc(size);
+
+	if (result == NULL)
+		goto error;
+
+	return result;
 }
 
 
 void InterruptOcaml(void)
 {
-  if (! GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pi.dwProcessId)) {
-    char message[1024];
-    sprintf(message, "GenerateConsole failed: %ld\n", GetLastError());
-    MessageBox(NULL, message, "Ocaml", MB_OK);
-  }
-  WriteToPipe(" ");
+	if (!GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pi.dwProcessId)) {
+		char message[1024];
+		sprintf(message, "GenerateConsole failed: %lu\n", GetLastError());
+		MessageBox(NULL, message, "Ocaml", MB_OK);
+	}
+	WriteToPipe(" ");
 }
diff --git a/yacc/Makefile.Mac b/yacc/Makefile.Mac
deleted file mode 100644
index eb58dcd8..00000000
--- a/yacc/Makefile.Mac
+++ /dev/null
@@ -1,54 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#            Damien Doligez, projet Para, INRIA Rocquencourt            #
-#                                                                       #
-#   Copyright 1999 Institut National de Recherche en Informatique et    #
-#   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the Q Public License version 1.0.                #
-#                                                                       #
-#########################################################################
-
-# $Id: Makefile.Mac,v 1.10 2001/07/12 13:37:35 doligez Exp $
-
-# Makefile for the parser generator.
-
-PPCC = mrc
-PPCCOptions = -includes unix {cdbgflag} -w 2,35
-PPCLinkOptions = -d {ldbgflag}
-PPCLibs = "{sharedlibraries}MathLib" "{ppclibraries}PPCCRuntime.o" ¶
-          "{ppclibraries}PPCToolLibs.o" "{sharedlibraries}StdCLib" ¶
-          "{ppclibraries}StdCRuntime.o" "{sharedlibraries}InterfaceLib"
-
-PPCOBJS = closure.c.x error.c.x lalr.c.x lr0.c.x main.c.x mkpar.c.x ¶
-       output.c.x ¶
-       reader.c.x skeleton.c.x symtab.c.x verbose.c.x warshall.c.x ¶
-       rotatecursor.c.x
-
-all Ä ocamlyacc
-
-ocamlyacc ÄÄ {PPCOBJS}
-    ppclink -c 'MPS ' -t MPST {PPCLinkOptions} -o ocamlyacc {PPCOBJS} {PPCLibs}
-
-clean Ä
-    delete -i Å.c.x || set status 0
-    delete -i ocamlyacc
-
-rotatecursor.c.x Ä ::byterun:rotatecursor.c ::byterun:rotatecursor.h
-    {ppcc} {ppccoptions} -I ::byterun: -o rotatecursor.c.x ::byterun:rotatecursor.c
-
-depend Ä
-
-closure.c.x Ä defs.h ::byterun:rotatecursor.h
-error.c.x Ä defs.h ::byterun:rotatecursor.h
-lalr.c.x Ä defs.h ::byterun:rotatecursor.h
-lr0.c.x Ä defs.h ::byterun:rotatecursor.h
-main.c.x Ä defs.h ::byterun:rotatecursor.h
-mkpar.c.x Ä defs.h ::byterun:rotatecursor.h
-output.c.x Ä defs.h ::byterun:rotatecursor.h
-reader.c.x Ä defs.h ::byterun:rotatecursor.h
-skeleton.c.x Ä defs.h ::byterun:rotatecursor.h
-symtab.c.x Ä defs.h ::byterun:rotatecursor.h
-verbose.c.x Ä defs.h ::byterun:rotatecursor.h
-warshall.c.x Ä defs.h ::byterun:rotatecursor.h
diff --git a/yacc/defs.h b/yacc/defs.h
index f1af3950..7991b590 100644
--- a/yacc/defs.h
+++ b/yacc/defs.h
@@ -12,7 +12,7 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: defs.h,v 1.20 2003/09/03 13:26:10 doligez Exp $ */
+/* $Id: defs.h,v 1.22 2004/04/21 23:26:05 doligez Exp $ */
 
 #include <assert.h>
 #include <ctype.h>
@@ -22,10 +22,6 @@
 #include <stdlib.h>
 #include "../config/s.h"
 
-#if macintosh
-#include "../byterun/rotatecursor.h"
-#endif
-
 /*  machine-dependent definitions                              */
 /*  the following definitions are for the Tahoe                */
 /*  they might have to be changed for other machines           */
@@ -120,19 +116,6 @@
 
 /*  storage allocation macros  */
 
-#if macintosh
-
-#define INTERACT() ROTATECURSOR_MAGIC ()
-
-#define CALLOC(k,n)  (INTERACT (), calloc((unsigned)(k),(unsigned)(n)))
-#define FREE(x)      (INTERACT (), free((char*)(x)))
-#define MALLOC(n)    (INTERACT (), malloc((unsigned)(n)))
-#define NEW(t)       (INTERACT (), (t*)allocate(sizeof(t)))
-#define NEW2(n,t)    (INTERACT (), (t*)allocate((unsigned)((n)*sizeof(t))))
-#define REALLOC(p,n) (INTERACT (), realloc((char*)(p),(unsigned)(n)))
-
-#else
-
 #define CALLOC(k,n)      (calloc((unsigned)(k),(unsigned)(n)))
 #define FREE(x)          (free((char*)(x)))
 #define MALLOC(n)        (malloc((unsigned)(n)))
@@ -140,8 +123,6 @@
 #define NEW2(n,t)        ((t*)allocate((unsigned)((n)*sizeof(t))))
 #define REALLOC(p,n)     (realloc((char*)(p),(unsigned)(n)))
 
-#endif /* macintosh */
-
 
 /*  the structure of a symbol table entry  */
 
@@ -234,6 +215,7 @@ extern char *myname;
 extern char *cptr;
 extern char *line;
 extern int lineno;
+extern char *virtual_input_file_name;
 extern int outline;
 
 extern char *action_file_name;
diff --git a/yacc/error.c b/yacc/error.c
index 3cd1dabe..150e27cf 100644
--- a/yacc/error.c
+++ b/yacc/error.c
@@ -12,7 +12,7 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: error.c,v 1.11 2003/07/17 14:51:43 xleroy Exp $ */
+/* $Id: error.c,v 1.13 2004/06/12 11:59:11 xleroy Exp $ */
 
 /* routines for printing error messages  */
 
@@ -42,7 +42,7 @@ void open_error(char *filename)
 void unexpected_EOF(void)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", unexpected end-of-file\n",
-            myname, lineno, input_file_name);
+            myname, lineno, virtual_input_file_name);
     done(1);
 }
 
@@ -54,7 +54,7 @@ void print_pos(char *st_line, char *st_cptr)
     if (st_line == 0) return;
     for (s = st_line; *s != '\n'; ++s)
     {
-        if (isprint(*s) || *s == '\t')
+        if (isprint((unsigned char) *s) || *s == '\t')
             putc(*s, stderr);
         else
             putc('?', stderr);
@@ -75,7 +75,7 @@ void print_pos(char *st_line, char *st_cptr)
 void syntax_error(int st_lineno, char *st_line, char *st_cptr)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", syntax error\n",
-            myname, st_lineno, input_file_name);
+            myname, st_lineno, virtual_input_file_name);
     print_pos(st_line, st_cptr);
     done(1);
 }
@@ -84,7 +84,7 @@ void syntax_error(int st_lineno, char *st_line, char *st_cptr)
 void unterminated_comment(int c_lineno, char *c_line, char *c_cptr)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", unmatched /*\n",
-            myname, c_lineno, input_file_name);
+            myname, c_lineno, virtual_input_file_name);
     print_pos(c_line, c_cptr);
     done(1);
 }
@@ -93,7 +93,7 @@ void unterminated_comment(int c_lineno, char *c_line, char *c_cptr)
 void unterminated_string(int s_lineno, char *s_line, char *s_cptr)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", unterminated string\n",
-            myname, s_lineno, input_file_name);
+            myname, s_lineno, virtual_input_file_name);
     print_pos(s_line, s_cptr);
     done(1);
 }
@@ -102,7 +102,7 @@ void unterminated_string(int s_lineno, char *s_line, char *s_cptr)
 void unterminated_text(int t_lineno, char *t_line, char *t_cptr)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", unmatched %%{\n",
-            myname, t_lineno, input_file_name);
+            myname, t_lineno, virtual_input_file_name);
     print_pos(t_line, t_cptr);
     done(1);
 }
@@ -111,7 +111,7 @@ void unterminated_text(int t_lineno, char *t_line, char *t_cptr)
 void unterminated_union(int u_lineno, char *u_line, char *u_cptr)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", unterminated %%union \
-declaration\n", myname, u_lineno, input_file_name);
+declaration\n", myname, u_lineno, virtual_input_file_name);
     print_pos(u_line, u_cptr);
     done(1);
 }
@@ -120,7 +120,7 @@ declaration\n", myname, u_lineno, input_file_name);
 void over_unionized(char *u_cptr)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", too many %%union \
-declarations\n", myname, lineno, input_file_name);
+declarations\n", myname, lineno, virtual_input_file_name);
     print_pos(line, u_cptr);
     done(1);
 }
@@ -129,7 +129,7 @@ declarations\n", myname, lineno, input_file_name);
 void illegal_tag(int t_lineno, char *t_line, char *t_cptr)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", illegal tag\n",
-            myname, t_lineno, input_file_name);
+            myname, t_lineno, virtual_input_file_name);
     print_pos(t_line, t_cptr);
     done(1);
 }
@@ -138,7 +138,7 @@ void illegal_tag(int t_lineno, char *t_line, char *t_cptr)
 void illegal_character(char *c_cptr)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", illegal character\n",
-            myname, lineno, input_file_name);
+            myname, lineno, virtual_input_file_name);
     print_pos(line, c_cptr);
     done(1);
 }
@@ -147,7 +147,7 @@ void illegal_character(char *c_cptr)
 void used_reserved(char *s)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", illegal use of reserved symbol \
-%s\n", myname, lineno, input_file_name, s);
+%s\n", myname, lineno, virtual_input_file_name, s);
     done(1);
 }
 
@@ -155,7 +155,7 @@ void used_reserved(char *s)
 void tokenized_start(char *s)
 {
      fprintf(stderr, "%s: e - line %d of \"%s\", the start symbol %s cannot be \
-declared to be a token\n", myname, lineno, input_file_name, s);
+declared to be a token\n", myname, lineno, virtual_input_file_name, s);
      done(1);
 }
 
@@ -163,35 +163,35 @@ declared to be a token\n", myname, lineno, input_file_name, s);
 void retyped_warning(char *s)
 {
     fprintf(stderr, "%s: w - line %d of \"%s\", the type of %s has been \
-redeclared\n", myname, lineno, input_file_name, s);
+redeclared\n", myname, lineno, virtual_input_file_name, s);
 }
 
 
 void reprec_warning(char *s)
 {
     fprintf(stderr, "%s: w - line %d of \"%s\", the precedence of %s has been \
-redeclared\n", myname, lineno, input_file_name, s);
+redeclared\n", myname, lineno, virtual_input_file_name, s);
 }
 
 
 void revalued_warning(char *s)
 {
     fprintf(stderr, "%s: w - line %d of \"%s\", the value of %s has been \
-redeclared\n", myname, lineno, input_file_name, s);
+redeclared\n", myname, lineno, virtual_input_file_name, s);
 }
 
 
 void terminal_start(char *s)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", the entry point %s is a \
-token\n", myname, lineno, input_file_name, s);
+token\n", myname, lineno, virtual_input_file_name, s);
     done(1);
 }
 
 void too_many_entries(void)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", more than 256 entry points\n",
-            myname, lineno, input_file_name);
+            myname, lineno, virtual_input_file_name);
     done(1);
 }
 
@@ -199,7 +199,7 @@ void too_many_entries(void)
 void no_grammar(void)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", no grammar has been \
-specified\n", myname, lineno, input_file_name);
+specified\n", myname, lineno, virtual_input_file_name);
     done(1);
 }
 
@@ -207,7 +207,7 @@ specified\n", myname, lineno, input_file_name);
 void terminal_lhs(int s_lineno)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", a token appears on the lhs \
-of a production\n", myname, s_lineno, input_file_name);
+of a production\n", myname, s_lineno, virtual_input_file_name);
     done(1);
 }
 
@@ -215,14 +215,14 @@ of a production\n", myname, s_lineno, input_file_name);
 void prec_redeclared(void)
 {
     fprintf(stderr, "%s: w - line %d of  \"%s\", conflicting %%prec \
-specifiers\n", myname, lineno, input_file_name);
+specifiers\n", myname, lineno, virtual_input_file_name);
 }
 
 
 void unterminated_action(int a_lineno, char *a_line, char *a_cptr)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", unterminated action\n",
-            myname, a_lineno, input_file_name);
+            myname, a_lineno, virtual_input_file_name);
     print_pos(a_line, a_cptr);
     done(1);
 }
@@ -231,14 +231,14 @@ void unterminated_action(int a_lineno, char *a_line, char *a_cptr)
 void dollar_warning(int a_lineno, int i)
 {
     fprintf(stderr, "%s: w - line %d of \"%s\", $%d references beyond the \
-end of the current rule\n", myname, a_lineno, input_file_name, i);
+end of the current rule\n", myname, a_lineno, virtual_input_file_name, i);
 }
 
 
 void dollar_error(int a_lineno, char *a_line, char *a_cptr)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", illegal $-name\n",
-            myname, a_lineno, input_file_name);
+            myname, a_lineno, virtual_input_file_name);
     print_pos(a_line, a_cptr);
     done(1);
 }
@@ -247,7 +247,7 @@ void dollar_error(int a_lineno, char *a_line, char *a_cptr)
 void untyped_lhs(void)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", $$ is untyped\n",
-            myname, lineno, input_file_name);
+            myname, lineno, virtual_input_file_name);
     done(1);
 }
 
@@ -255,7 +255,7 @@ void untyped_lhs(void)
 void untyped_rhs(int i, char *s)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", $%d (%s) is untyped\n",
-            myname, lineno, input_file_name, i, s);
+            myname, lineno, virtual_input_file_name, i, s);
     done(1);
 }
 
@@ -263,21 +263,21 @@ void untyped_rhs(int i, char *s)
 void unknown_rhs(int i)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", $%d is unbound\n",
-            myname, lineno, input_file_name, i);
+            myname, lineno, virtual_input_file_name, i);
     done(1);
 }
 
 void illegal_token_ref(int i, char *name)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", $%d refers to terminal `%s', which has no argument\n",
-            myname, lineno, input_file_name, i, name);
+            myname, lineno, virtual_input_file_name, i, name);
     done(1);
 }
 
 void default_action_error(void)
 {
     fprintf(stderr, "%s: e - line %d of \"%s\", no action specified for this production\n",
-            myname, lineno, input_file_name);
+            myname, lineno, virtual_input_file_name);
     done(1);
 }
 
diff --git a/yacc/main.c b/yacc/main.c
index a8b9b43d..921f0e11 100644
--- a/yacc/main.c
+++ b/yacc/main.c
@@ -12,7 +12,7 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: main.c,v 1.17 2003/09/03 13:26:10 doligez Exp $ */
+/* $Id: main.c,v 1.18 2004/04/21 23:26:05 doligez Exp $ */
 
 #include <signal.h>
 #include <string.h>
@@ -39,6 +39,7 @@ char temp_form[] = "yacc.XXXXXXX";
 #endif
 
 int lineno;
+char *virtual_input_file_name = NULL;
 int outline;
 
 char *action_file_name;
diff --git a/yacc/reader.c b/yacc/reader.c
index 42ddc9b9..45367c8e 100644
--- a/yacc/reader.c
+++ b/yacc/reader.c
@@ -12,7 +12,7 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: reader.c,v 1.26 2003/07/23 23:03:00 doligez Exp $ */
+/* $Id: reader.c,v 1.28 2004/06/12 11:59:11 xleroy Exp $ */
 
 #include <string.h>
 #include "defs.h"
@@ -155,6 +155,51 @@ void skip_comment(void)
     }
 }
 
+char *substring (char *str, int start, int len)
+{
+  int i;
+  char *buf = MALLOC (len+1);
+  if (buf == NULL) return NULL;
+  for (i = 0; i < len; i++){
+    buf[i] = str[start+i];
+  }
+  return buf;
+}
+
+void parse_line_directive (void)
+{
+  int i = 0, j = 0;
+  int line_number = 0;
+  char *file_name = NULL;
+
+ again:
+  if (line == 0) return;
+  if (line[i] != '#') return;
+  ++ i;
+  while (line[i] == ' ' || line[i] == '\t') ++ i;
+  if (line[i] < '0' || line[i] > '9') return;
+  while (line[i] >= '0' && line[i] <= '9'){
+    line_number = line_number * 10 + line[i] - '0';
+    ++ i;
+  }
+  while (line[i] == ' ' || line[i] == '\t') ++ i;
+  if (line[i] == '"'){
+    ++ i;
+    j = i;
+    while (line[j] != '"' && line[j] != '\0') ++j;
+    if (line[j] == '"'){
+      file_name = substring (line, i, j - i);
+      if (file_name == NULL) no_space ();
+    }
+  }
+  lineno = line_number - 1;
+  if (file_name != NULL){
+    if (virtual_input_file_name != NULL) FREE (virtual_input_file_name);
+    virtual_input_file_name = file_name;
+  }
+  get_line ();
+  goto again;
+}
 
 int
 nextc(void)
@@ -164,6 +209,7 @@ nextc(void)
     if (line == 0)
     {
         get_line();
+        parse_line_directive ();
         if (line == 0)
             return (EOF);
     }
@@ -175,6 +221,7 @@ nextc(void)
         {
         case '\n':
             get_line();
+            parse_line_directive ();
             if (line == 0) return (EOF);
             s = cptr;
             break;
@@ -204,6 +251,7 @@ nextc(void)
             else if (s[1] == '/')
             {
                 get_line();
+                parse_line_directive ();
                 if (line == 0) return (EOF);
                 s = cptr;
                 break;
@@ -380,8 +428,11 @@ loop:
           fwrite(cptr, 1, 2, f);
           cptr += 2;
         } else
-        if (cptr[0] == '\\' && isdigit(cptr[1]) && isdigit(cptr[2]) &&
-            isdigit(cptr[3]) && cptr[4] == '\'') {
+        if (cptr[0] == '\\'
+            && isdigit((unsigned char) cptr[1])
+            && isdigit((unsigned char) cptr[2])
+            && isdigit((unsigned char) cptr[3])
+            && cptr[4] == '\'') {
           fwrite(cptr, 1, 5, f);
           cptr += 5;
         } else
@@ -726,10 +777,10 @@ is_reserved(char *name)
             strcmp(name, "$end") == 0)
         return (1);
 
-    if (name[0] == '$' && name[1] == '$' && isdigit(name[2]))
+    if (name[0] == '$' && name[1] == '$' && isdigit((unsigned char) name[2]))
     {
         s = name + 3;
-        while (isdigit(*s)) ++s;
+        while (isdigit((unsigned char) *s)) ++s;
         if (*s == NUL) return (1);
     }
 
@@ -1245,7 +1296,7 @@ loop:
     c = *cptr;
     if (c == '$')
     {
-        if (isdigit(cptr[1]))
+        if (isdigit((unsigned char) cptr[1]))
         {
             ++cptr;
             i = get_number();
@@ -1336,8 +1387,11 @@ loop:
           fwrite(cptr, 1, 2, f);
           cptr += 2;
         } else
-        if (cptr[0] == '\\' && isdigit(cptr[1]) && isdigit(cptr[2]) &&
-            isdigit(cptr[3]) && cptr[4] == '\'') {
+        if (cptr[0] == '\\' 
+            && isdigit((unsigned char) cptr[1])
+            && isdigit((unsigned char) cptr[2])
+            && isdigit((unsigned char) cptr[3])
+            && cptr[4] == '\'') {
           fwrite(cptr, 1, 5, f);
           cptr += 5;
         } else
@@ -1823,6 +1877,8 @@ void print_grammar(void)
 
 void reader(void)
 {
+    virtual_input_file_name = substring (input_file_name, 0,
+                                         strlen (input_file_name));
     create_symbol_table();
     read_declarations();
     output_token_type();
-- 
2.30.2